git.iko.soy/elk
on c5b225d help sign in
elk/src/Nitpick/PatternMatches.hs
382 lines 9.1 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
35type Result warning a =
36 Result.Result () warning Error.Error a
39patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
40patternMatches interfaces (Module.Module name _ info) =
41 let
42 arityDict =
43 toArityDict interfaces name (Module.unions info)
45 variantDict =
46 Map.map (Map.map _size) arityDict
47 in
48 pure variantDict
49 <* checkExpression arityDict (Module.program info)
53-- CHECK EXPRESSIONS
56checkExpression :: ArityDict -> C.Expr -> Result wrn ()
57checkExpression arityDict (A.A region expression) =
58 let
59 go =
60 checkExpression arityDict
62 go2 a b =
63 go a <* go b
64 in
65 case expression of
66 C.Literal _ ->
67 Result.ok ()
69 C.Var _ ->
70 Result.ok ()
72 C.List listExprs ->
73 F.traverse_ go listExprs
75 C.Binop _ leftExpr rightExpr ->
76 go2 leftExpr rightExpr
78 C.Lambda pattern@(A.A patRegion _) body ->
79 checkPatterns arityDict patRegion Error.Arg [pattern]
80 <* go body
82 C.App func arg ->
83 go2 func arg
85 C.If branches finally ->
86 F.traverse_ (uncurry go2) branches
87 <* go finally
89 C.Let defs body ->
90 go body
91 <* F.traverse_ goDef defs
92 where
93 goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
94 checkPatterns arityDict patRegion Error.LetBound [pattern]
95 <* go expr
97 C.Case expr branches ->
98 go expr
99 <* checkPatterns arityDict region Error.Case (map fst branches)
100 <* F.traverse_ (go . snd) branches
102 C.Ctor _ctor exprs ->
103 F.traverse_ go exprs
105 C.Access record _field ->
106 go record
108 C.Update record fields ->
109 go record
110 <* F.traverse_ (go . snd) fields
112 C.Record fields ->
113 F.traverse_ (go . snd) fields
115 C.Cmd _ ->
116 Result.ok ()
118 C.Sub _ ->
119 Result.ok ()
121 C.OutgoingPort _ _ ->
122 Result.ok ()
124 C.IncomingPort _ _ ->
125 Result.ok ()
127 C.Program _ _ ->
128 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
130 C.SaveEnv _ _ ->
131 Result.ok ()
133 C.GLShader _ _ _ ->
134 Result.ok ()
138-- CHECK PATTERNS
141checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
142checkPatterns arityDict region origin patterns =
143 let
144 matrix =
145 map (\p -> [fromCanonicalPattern p]) patterns
146 in
147 if isUseful arityDict matrix [Anything] then
148 Result.throw region (Error.Incomplete origin (error "TODO"))
150 else
151 return ()
155-- MISSING PATTERNS
158--missingPatterns :: [[Pattern]] -> Int -> [Pattern]
159--missingPatterns matrix n =
160-- case matrix of
161-- [] ->
166-- REDUNDANT PATTERNS
169isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
170isUseful arityDict matrix vector =
171 case (matrix, vector) of
172 ([], _) ->
173 True
175 (_, []) ->
176 False
178 (_, firstPattern : patterns) ->
179 case firstPattern of
180 Ctor name args ->
181 let
182 newMatrix =
183 Maybe.mapMaybe (specialize name (length args)) matrix
184 in
185 isUseful arityDict newMatrix (args ++ patterns)
187 Anything ->
188 case isComplete arityDict matrix of
189 Nothing ->
190 isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
192 Just arityInfo ->
193 let
194 isUsefulHelp (ctor, arity) =
195 isUseful
196 arityDict
197 (Maybe.mapMaybe (specialize ctor arity) matrix)
198 (replicate arity Anything ++ patterns)
199 in
200 any isUsefulHelp arityInfo
202 Literal literal ->
203 let
204 newMatrix =
205 Maybe.mapMaybe (specializeLiteral literal) matrix
206 in
207 isUseful arityDict newMatrix patterns
211-- SPECIALIZE MATRICES
214specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
215specialize ctorName arity row =
216 case row of
217 [] ->
218 error "Compiler error! Empty matrices should not get specialized."
220 firstPattern : patterns ->
221 case firstPattern of
222 Ctor name args ->
223 if name == ctorName then Just (args ++ patterns) else Nothing
225 Anything ->
226 Just (replicate arity Anything ++ patterns)
228 Literal _ ->
229 error $
230 "Compiler bug! After type checking, constructors and literals\
231 \ should never align in pattern match exhaustiveness checks."
234specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
235specializeLiteral literal row =
236 case row of
237 [] ->
238 error "Compiler error! Empty matrices should not get specialized."
240 firstPattern : patterns ->
241 case firstPattern of
242 Literal lit ->
243 if lit == literal then Just patterns else Nothing
245 Anything ->
246 Just patterns
248 Ctor _ _ ->
249 error $
250 "Compiler bug! After type checking, constructors and literals\
251 \ should never align in pattern match exhaustiveness checks."
254toDefault :: [Pattern] -> Maybe [Pattern]
255toDefault row =
256 case row of
257 [] ->
258 Nothing
260 Ctor _ _ : _ ->
261 Nothing
263 Anything : patterns ->
264 Just patterns
266 Literal _ : _ ->
267 Nothing
271-- ALL CONSTRUCTORS ARE PRESENT?
274isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
275isComplete arityDict matrix =
276 let
277 ctorSet =
278 List.foldl' isCompleteHelp Set.empty matrix
280 actual =
281 Set.size ctorSet
282 in
283 if actual == 0 then
284 Nothing
286 else
287 let
288 (ArityInfo expected info) =
289 getArityInfo (Set.findMin ctorSet) arityDict
290 in
291 if expected == actual then Just info else Nothing
294isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
295isCompleteHelp ctors row =
296 case row of
297 Ctor name _ : _ ->
298 Set.insert name ctors
300 _ ->
301 ctors
305-- ARITY DICT
308type ArityDict =
309 Map.Map Var.Home (Map.Map String ArityInfo)
312data ArityInfo =
313 ArityInfo
314 { _size :: !Int
315 , _info :: [(Var.Canonical, Int)]
316 }
319toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
320toArityDict interfaces localName localUnions =
321 interfaces
322 |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
323 |> Map.mapKeysMonotonic Var.Module
324 |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
325 |> Map.union builtinDict
328builtinDict :: ArityDict
329builtinDict =
330 let
331 listInfo =
332 ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]
334 boolInfo =
335 ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]
336 in
337 Map.singleton Var.BuiltIn $ Map.fromList $
338 [ ("::", listInfo)
339 , ("[]", listInfo)
340 , ("True", boolInfo)
341 , ("False", boolInfo)
342 ]
343 ++ map makeTupleInfo [0..8]
346makeTupleInfo :: Int -> ( String, ArityInfo )
347makeTupleInfo n =
348 let
349 name =
350 "_Tuple" ++ show n
351 in
352 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
355toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo
356toArityEntry name unions =
357 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
360toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]
361toArityEntryHelp name (_tvars, ctors) =
362 let
363 arityInfo =
364 ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
365 in
366 map (second (\_ -> arityInfo)) ctors
369getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
370getArityInfo var@(Var.Canonical home name) arityDict =
371 case Map.lookup name =<< Map.lookup home arityDict of
372 Just arityInfo ->
373 arityInfo
375 Nothing ->
376 if Help.isTuple name then
377 ArityInfo 1 [ (var, read (drop 6 name)) ]
378 else
379 error
380 "Since the Nitpick phase happens after canonicalization and type\
381 \ inference, it is impossible that a pattern in a case cannot be\
382 \ found."