git.iko.soy/elk
on 2a9c8d7 help sign in
elk/src/Nitpick/PatternMatches.hs
398 lines 9.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Nitpick.PatternMatches (patternMatches) where
4{- The algorithm used here comes from "Warnings for Pattern Matching"
5by Luc Maranget. Check it out for more information!
7http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
9-}
11import Control.Arrow ((***), second)
12import qualified Data.Foldable as F
13import qualified Data.List as List
14import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
16import qualified Data.Set as Set
18import qualified AST.Expression.Canonical as C
19import qualified AST.Helpers as Help
20import qualified AST.Literal as L
21import qualified AST.Module as Module
22import qualified AST.Module.Name as ModuleName
23import qualified AST.Pattern as Pattern
24import qualified AST.Variable as Var
25import Elm.Utils ((|>))
26import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
27import qualified Optimize.DecisionTree as DT
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error.Pattern as Error
30import qualified Reporting.Region as Region
31import qualified Reporting.Result as Result
35-- NITPICK PATTERN MATCHES
38type Result warning a =
39 Result.Result () warning Error.Error a
42patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
43patternMatches interfaces (Module.Module name _ info) =
44 let
45 arityDict =
46 toArityDict interfaces name (Module.unions info)
48 variantDict =
49 Map.map (Map.map _size) arityDict
50 in
51 pure variantDict
52 <* checkExpression arityDict (Module.program info)
55checkExpression :: ArityDict -> C.Expr -> Result wrn ()
56checkExpression arityDict (A.A region expression) =
57 let
58 go =
59 checkExpression arityDict
61 go2 a b =
62 go a <* go b
63 in
64 case expression of
65 C.Literal _ ->
66 Result.ok ()
68 C.Var _ ->
69 Result.ok ()
71 C.List listExprs ->
72 F.traverse_ go listExprs
74 C.Binop _ leftExpr rightExpr ->
75 go2 leftExpr rightExpr
77 C.Lambda pattern@(A.A patRegion _) body ->
78 checkPatterns arityDict patRegion Error.Arg [pattern]
79 <* go body
81 C.App func arg ->
82 go2 func arg
84 C.If branches finally ->
85 F.traverse_ (uncurry go2) branches
86 <* go finally
88 C.Let defs body ->
89 go body
90 <* F.traverse_ goDef defs
91 where
92 goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
93 checkPatterns arityDict patRegion Error.LetBound [pattern]
94 <* go expr
96 C.Case expr branches ->
97 go expr
98 <* checkPatterns arityDict region Error.Case (map fst branches)
99 <* F.traverse_ (go . snd) branches
101 C.Ctor _ctor exprs ->
102 F.traverse_ go exprs
104 C.Access record _field ->
105 go record
107 C.Update record fields ->
108 go record
109 <* F.traverse_ (go . snd) fields
111 C.Record fields ->
112 F.traverse_ (go . snd) fields
114 C.Cmd _ ->
115 Result.ok ()
117 C.Sub _ ->
118 Result.ok ()
120 C.OutgoingPort _ _ ->
121 Result.ok ()
123 C.IncomingPort _ _ ->
124 Result.ok ()
126 C.Program _ _ ->
127 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
129 C.SaveEnv _ _ ->
130 Result.ok ()
132 C.GLShader _ _ _ ->
133 Result.ok ()
137-- CHECK PATTERNS
140checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
141checkPatterns arityDict region origin patterns =
142 do matrix <- checkRedundant arityDict region [] patterns
143 if isUseful arityDict matrix [Anything]
144 then Result.throw region (Error.Incomplete origin (error "TODO"))
145 else Result.ok ()
148checkRedundant
149 :: ArityDict
150 -> Region.Region
151 -> [[Pattern]]
152 -> [Pattern.Canonical]
153 -> Result wrn [[Pattern]]
154checkRedundant arityDict region checked unchecked =
155 case unchecked of
156 [] ->
157 Result.ok checked
159 nextPattern@(A.A patRegion _) : rest ->
160 let
161 next =
162 [fromCanonicalPattern nextPattern]
163 in
164 if isUseful arityDict checked next then
165 checkRedundant arityDict region (next : checked) rest
166 else
167 Result.throw region (Error.Redundant patRegion (length checked + 1))
171-- MISSING PATTERNS
174--missingPatterns :: [[Pattern]] -> Int -> [Pattern]
175--missingPatterns matrix n =
176-- case matrix of
177-- [] ->
182-- DETECT USEFUL PATTERNS
185isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
186isUseful arityDict matrix vector =
187 case (matrix, vector) of
188 ([], _) ->
189 True
191 (_, []) ->
192 False
194 (_, firstPattern : patterns) ->
195 case firstPattern of
196 Ctor name args ->
197 let
198 newMatrix =
199 Maybe.mapMaybe (specialize name (length args)) matrix
200 in
201 isUseful arityDict newMatrix (args ++ patterns)
203 Anything ->
204 case isComplete arityDict matrix of
205 Nothing ->
206 isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
208 Just arityInfo ->
209 let
210 isUsefulHelp (ctor, arity) =
211 isUseful
212 arityDict
213 (Maybe.mapMaybe (specialize ctor arity) matrix)
214 (replicate arity Anything ++ patterns)
215 in
216 any isUsefulHelp arityInfo
218 Literal literal ->
219 let
220 newMatrix =
221 Maybe.mapMaybe (specializeLiteral literal) matrix
222 in
223 isUseful arityDict newMatrix patterns
227-- SPECIALIZE MATRICES
230specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
231specialize ctorName arity row =
232 case row of
233 [] ->
234 error "Compiler error! Empty matrices should not get specialized."
236 firstPattern : patterns ->
237 case firstPattern of
238 Ctor name args ->
239 if name == ctorName then Just (args ++ patterns) else Nothing
241 Anything ->
242 Just (replicate arity Anything ++ patterns)
244 Literal _ ->
245 error $
246 "Compiler bug! After type checking, constructors and literals\
247 \ should never align in pattern match exhaustiveness checks."
250specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
251specializeLiteral literal row =
252 case row of
253 [] ->
254 error "Compiler error! Empty matrices should not get specialized."
256 firstPattern : patterns ->
257 case firstPattern of
258 Literal lit ->
259 if lit == literal then Just patterns else Nothing
261 Anything ->
262 Just patterns
264 Ctor _ _ ->
265 error $
266 "Compiler bug! After type checking, constructors and literals\
267 \ should never align in pattern match exhaustiveness checks."
270toDefault :: [Pattern] -> Maybe [Pattern]
271toDefault row =
272 case row of
273 [] ->
274 Nothing
276 Ctor _ _ : _ ->
277 Nothing
279 Anything : patterns ->
280 Just patterns
282 Literal _ : _ ->
283 Nothing
287-- ALL CONSTRUCTORS ARE PRESENT?
290isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
291isComplete arityDict matrix =
292 let
293 ctorSet =
294 List.foldl' isCompleteHelp Set.empty matrix
296 actual =
297 Set.size ctorSet
298 in
299 if actual == 0 then
300 Nothing
302 else
303 let
304 (ArityInfo expected info) =
305 getArityInfo (Set.findMin ctorSet) arityDict
306 in
307 if expected == actual then Just info else Nothing
310isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
311isCompleteHelp ctors row =
312 case row of
313 Ctor name _ : _ ->
314 Set.insert name ctors
316 _ ->
317 ctors
321-- ARITY DICT
324type ArityDict =
325 Map.Map Var.Home (Map.Map String ArityInfo)
328data ArityInfo =
329 ArityInfo
330 { _size :: !Int
331 , _info :: [(Var.Canonical, Int)]
332 }
335toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
336toArityDict interfaces localName localUnions =
337 interfaces
338 |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
339 |> Map.mapKeysMonotonic Var.Module
340 |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
341 |> Map.union builtinDict
344builtinDict :: ArityDict
345builtinDict =
346 let
347 listInfo =
348 ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]
350 boolInfo =
351 ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]
352 in
353 Map.singleton Var.BuiltIn $ Map.fromList $
354 [ ("::", listInfo)
355 , ("[]", listInfo)
356 , ("True", boolInfo)
357 , ("False", boolInfo)
358 ]
359 ++ map makeTupleInfo [0..8]
362makeTupleInfo :: Int -> ( String, ArityInfo )
363makeTupleInfo n =
364 let
365 name =
366 "_Tuple" ++ show n
367 in
368 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
371toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo
372toArityEntry name unions =
373 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
376toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]
377toArityEntryHelp name (_tvars, ctors) =
378 let
379 arityInfo =
380 ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
381 in
382 map (second (\_ -> arityInfo)) ctors
385getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
386getArityInfo var@(Var.Canonical home name) arityDict =
387 case Map.lookup name =<< Map.lookup home arityDict of
388 Just arityInfo ->
389 arityInfo
391 Nothing ->
392 if Help.isTuple name then
393 ArityInfo 1 [ (var, read (drop 6 name)) ]
394 else
395 error
396 "Since the Nitpick phase happens after canonicalization and type\
397 \ inference, it is impossible that a pattern in a case cannot be\
398 \ found."