git.iko.soy/elk
on ea2a61e help sign in
elk/src/Nitpick/PatternMatches.hs
455 lines 11 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 case isExhaustive arityDict matrix 1 of
144 [] ->
145 Result.ok ()
147 badPatterns ->
148 Result.throw region (Error.Incomplete origin (map head badPatterns))
152-- EXHAUSTIVE PATTERNS
155isExhaustive :: ArityDict -> [[Pattern]] -> Int -> [[Pattern]]
156isExhaustive arityDict matrix n =
157 case (matrix, n) of
158 ([], _) ->
159 [replicate n Anything]
161 (_, 0) ->
162 []
164 (_, _) ->
165 let
166 ctorSet =
167 List.foldl' isCompleteHelp Set.empty matrix
169 actual =
170 Set.size ctorSet
171 in
172 if actual == 0 then
173 (:) Anything
174 <$> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
176 else
177 let
178 (ArityInfo expected info) =
179 getArityInfo (Set.findMin ctorSet) arityDict
180 in
181 if actual < expected then
182 (:)
183 <$> Maybe.mapMaybe (isMissing ctorSet) info
184 <*> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
186 else
187 let
188 isExhaustiveHelp (name, arity) =
189 recoverCtor name arity <$>
190 isExhaustive
191 arityDict
192 (Maybe.mapMaybe (specialize name arity) matrix)
193 (arity + n - 1)
194 in
195 concatMap isExhaustiveHelp info
198isMissing :: Set.Set Var.Canonical -> (Var.Canonical, Int) -> Maybe Pattern
199isMissing ctorSet (name, arity) =
200 if Set.member name ctorSet then
201 Nothing
203 else
204 Just (Ctor name (replicate arity Anything))
207recoverCtor :: Var.Canonical -> Int -> [Pattern] -> [Pattern]
208recoverCtor name arity patterns =
209 let
210 (args, rest) =
211 splitAt arity patterns
212 in
213 Ctor name args : rest
217-- REDUNDANT PATTERNS
220checkRedundant
221 :: ArityDict
222 -> Region.Region
223 -> [[Pattern]]
224 -> [Pattern.Canonical]
225 -> Result wrn [[Pattern]]
226checkRedundant arityDict region checked unchecked =
227 case unchecked of
228 [] ->
229 Result.ok checked
231 nextPattern@(A.A patRegion _) : rest ->
232 let
233 next =
234 [fromCanonicalPattern nextPattern]
235 in
236 if isUseful arityDict checked next then
237 checkRedundant arityDict region (next : checked) rest
238 else
239 Result.throw region (Error.Redundant patRegion (length checked + 1))
242isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
243isUseful arityDict matrix vector =
244 case (matrix, vector) of
245 ([], _) ->
246 True
248 (_, []) ->
249 False
251 (_, firstPattern : patterns) ->
252 case firstPattern of
253 Ctor name args ->
254 let
255 newMatrix =
256 Maybe.mapMaybe (specialize name (length args)) matrix
257 in
258 isUseful arityDict newMatrix (args ++ patterns)
260 Anything ->
261 case isComplete arityDict matrix of
262 Nothing ->
263 isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
265 Just arityInfo ->
266 let
267 isUsefulHelp (ctor, arity) =
268 isUseful
269 arityDict
270 (Maybe.mapMaybe (specialize ctor arity) matrix)
271 (replicate arity Anything ++ patterns)
272 in
273 any isUsefulHelp arityInfo
275 Literal literal ->
276 let
277 newMatrix =
278 Maybe.mapMaybe (specializeLiteral literal) matrix
279 in
280 isUseful arityDict newMatrix patterns
284-- SPECIALIZE MATRICES
287specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
288specialize ctorName arity row =
289 case row of
290 [] ->
291 error "Compiler error! Empty matrices should not get specialized."
293 firstPattern : patterns ->
294 case firstPattern of
295 Ctor name args ->
296 if name == ctorName then Just (args ++ patterns) else Nothing
298 Anything ->
299 Just (replicate arity Anything ++ patterns)
301 Literal _ ->
302 error $
303 "Compiler bug! After type checking, constructors and literals\
304 \ should never align in pattern match exhaustiveness checks."
307specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
308specializeLiteral literal row =
309 case row of
310 [] ->
311 error "Compiler error! Empty matrices should not get specialized."
313 firstPattern : patterns ->
314 case firstPattern of
315 Literal lit ->
316 if lit == literal then Just patterns else Nothing
318 Anything ->
319 Just patterns
321 Ctor _ _ ->
322 error $
323 "Compiler bug! After type checking, constructors and literals\
324 \ should never align in pattern match exhaustiveness checks."
327toDefault :: [Pattern] -> Maybe [Pattern]
328toDefault row =
329 case row of
330 [] ->
331 Nothing
333 Ctor _ _ : _ ->
334 Nothing
336 Anything : patterns ->
337 Just patterns
339 Literal _ : _ ->
340 Nothing
344-- ALL CONSTRUCTORS ARE PRESENT?
347isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
348isComplete arityDict matrix =
349 let
350 ctorSet =
351 List.foldl' isCompleteHelp Set.empty matrix
353 actual =
354 Set.size ctorSet
355 in
356 if actual == 0 then
357 Nothing
359 else
360 let
361 (ArityInfo expected info) =
362 getArityInfo (Set.findMin ctorSet) arityDict
363 in
364 if expected == actual then Just info else Nothing
367isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
368isCompleteHelp ctors row =
369 case row of
370 Ctor name _ : _ ->
371 Set.insert name ctors
373 _ ->
374 ctors
378-- ARITY DICT
381type ArityDict =
382 Map.Map Var.Home (Map.Map String ArityInfo)
385data ArityInfo =
386 ArityInfo
387 { _size :: !Int
388 , _info :: [(Var.Canonical, Int)]
389 }
392toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
393toArityDict interfaces localName localUnions =
394 interfaces
395 |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
396 |> Map.mapKeysMonotonic Var.Module
397 |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
398 |> Map.union builtinDict
401builtinDict :: ArityDict
402builtinDict =
403 let
404 listInfo =
405 ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]
407 boolInfo =
408 ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]
409 in
410 Map.singleton Var.BuiltIn $ Map.fromList $
411 [ ("::", listInfo)
412 , ("[]", listInfo)
413 , ("True", boolInfo)
414 , ("False", boolInfo)
415 ]
416 ++ map makeTupleInfo [0..8]
419makeTupleInfo :: Int -> ( String, ArityInfo )
420makeTupleInfo n =
421 let
422 name =
423 "_Tuple" ++ show n
424 in
425 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
428toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo
429toArityEntry name unions =
430 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
433toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]
434toArityEntryHelp name (_tvars, ctors) =
435 let
436 arityInfo =
437 ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
438 in
439 map (second (\_ -> arityInfo)) ctors
442getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
443getArityInfo var@(Var.Canonical home name) arityDict =
444 case Map.lookup name =<< Map.lookup home arityDict of
445 Just arityInfo ->
446 arityInfo
448 Nothing ->
449 if Help.isTuple name then
450 ArityInfo 1 [ (var, read (drop 6 name)) ]
451 else
452 error
453 "Since the Nitpick phase happens after canonicalization and type\
454 \ inference, it is impossible that a pattern in a case cannot be\
455 \ found."