git.iko.soy/elk
on master help sign in
Update exhaustiveness checks for more explicit Can.Pattern
e41ae10Evan Czaplicki
src/Nitpick/Pattern.hsdeleted−110
compare with master
unifiedsplit
@@ -1,110 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Nitpick.Pattern
4− ( Pattern(..)
5− , fromCanonicalPattern
6− , toText
7− )
8− where
9−
10−import qualified Data.List as List
11−import Data.Monoid ((<>))
12−import Data.Text (Text)
13−import qualified Data.Text.Lazy as LazyText
14−import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
15−
16−import qualified AST.Literal as L
17−import qualified AST.Pattern as P
18−import qualified AST.Variable as Var
19−import qualified Reporting.Annotation as A
20−
21−
22−
23−-- PATTERN
24−
25−
26−data Pattern
27− = Ctor Var.Canonical [Pattern]
28− | Anything
29− | Literal L.Literal
30− deriving (Eq)
31−
32−
33−fromCanonicalPattern :: P.Canonical -> Pattern
34−fromCanonicalPattern (A.A _ pattern) =
35− case pattern of
36− P.Ctor name patterns ->
37− Ctor name (map fromCanonicalPattern patterns)
38−
39− P.Record _ ->
40− Anything
41−
42− P.Alias _ subPattern ->
43− fromCanonicalPattern subPattern
44−
45− P.Var _ ->
46− Anything
47−
48− P.Anything ->
49− Anything
50−
51− P.Literal (L.Boolean True) ->
52− Ctor Var.true []
53−
54− P.Literal (L.Boolean False) ->
55− Ctor Var.false []
56−
57− P.Literal literal ->
58− Literal literal
59−
60−
61−
62−-- TO STRING
63−
64−
65−toText :: Pattern -> Text
66−toText pattern =
67− LazyText.toStrict (toLazyText (toBuilder False pattern))
68−
69−
70−toBuilder :: Bool -> Pattern -> Builder
71−toBuilder needsParens pattern =
72− case pattern of
73− Ctor tag [first,rest] | Var.isCons tag ->
74− toBuilder (isCons first) first <> " :: " <> toBuilder False rest
75−
76− Ctor tag args ->
77− if Var.isTuple tag then
78− if null args then "()" else
79− "( "
80− <> mconcat (List.intersperse ", " (map (toBuilder False) args))
81− <> " )"
82−
83− else
84− addParensIf (needsParens && not (null args)) $
85− mconcat (List.intersperse " " (fromText (Var.toText tag) : map (toBuilder True) args))
86−
87− Anything ->
88− "_"
89−
90− Literal literal ->
91− L.toBuilder literal
92−
93−
94−addParensIf :: Bool -> Builder -> Builder
95−addParensIf needsParens str =
96− if needsParens then
97− "(" <> str <> ")"
98−
99− else
100− str
101−
102−
103−isCons :: Pattern -> Bool
104−isCons pattern =
105− case pattern of
106− Ctor tag [_,_] ->
107− Var.isCons tag
108−
109− _ ->
110− False
src/Nitpick/PatternMatches.hs+479−322
@@ -1,6 +1,13 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Nitpick.PatternMatches (patternMatches) where
3+module Nitpick.PatternMatches
4+ ( check
5+ , Error(..)
6+ , Context(..)
7+ , Pattern(..)
8+ )
9+ where
10+
4
11
5{- The algorithm used here comes from "Warnings for Pattern Matching"
12{- The algorithm used here comes from "Warnings for Pattern Matching"
6by Luc Maranget. Check it out for more information!
13by Luc Maranget. Check it out for more information!
@@ -9,331 +16,551 @@ http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
9
16
10-}
17-}
11
18
12−import Control.Arrow ((***), second)
13−import qualified Data.Foldable as F
14import qualified Data.List as List
19import qualified Data.List as List
15import qualified Data.Map as Map
20import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
21import qualified Data.Maybe as Maybe
17−import qualified Data.Set as Set
18import qualified Data.Text as Text
22import qualified Data.Text as Text
19−import Data.Text (Text)
23+
20−
21−import qualified AST.Expression.Canonical as C
24+import qualified AST.Canonical as Can
22−import qualified AST.Helpers as Help
23−import qualified AST.Literal as L
24−import qualified AST.Module as Module
25−import qualified AST.Module.Name as ModuleName
25+import qualified Elm.Name as N
26−import qualified AST.Pattern as Pattern
27−import qualified AST.Variable as Var
28−import Elm.Utils ((|>))
29−import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
30−import qualified Optimize.DecisionTree as DT
31import qualified Reporting.Annotation as A
26import qualified Reporting.Annotation as A
32−import qualified Reporting.Error.Pattern as Error
27+import qualified Reporting.Region as R
33−import qualified Reporting.Region as Region
34−import qualified Reporting.Result as Result
35
28
36
29
37
30
38−-- NITPICK PATTERN MATCHES
31+-- PATTERN
39
32
40
33
41−type Result warning a =
34+data Pattern
42− Result.Result () warning Error.Error a
35+ = Anything
36+ | Literal Literal
37+ | Ctor Can.CtorAlts N.Name [Pattern]
38+ deriving (Eq)
43
39
44
40
45−patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
41+data Literal
46−patternMatches interfaces (Module.Module name info) =
42+ = Chr Text.Text
47− let
43+ | Str Text.Text
48− arityDict =
44+ | Int Int
49− toArityDict interfaces name (Module.unions info)
45+ deriving (Eq)
50
46
51− variantDict =
52− Map.map (Map.map _size) arityDict
53− in
54− pure variantDict
55− <* checkExpression arityDict (Module.program info)
56
47
57
48
58−checkExpression :: ArityDict -> C.Expr -> Result wrn ()
49+-- CREATE SIMPLIFIED PATTERNS
59−checkExpression arityDict (A.A region expression) =
60− let
61− go =
62− checkExpression arityDict
63
50
64− go2 a b =
51+
65− go a <* go b
52+simplify :: Can.Pattern -> Pattern
66− in
53+simplify (A.At _ pattern) =
54+ case pattern of
55+ Can.PAnything ->
56+ Anything
57+
58+ Can.PVar _ ->
59+ Anything
60+
61+ Can.PRecord _ ->
62+ Anything
63+
64+ Can.PUnit ->
65+ Ctor unitAlts unitName []
66+
67+ Can.PTuple a b Nothing ->
68+ Ctor pairAlts pairName [ simplify a, simplify b ]
69+
70+ Can.PTuple a b (Just c) ->
71+ Ctor tripleAlts tripleName [ simplify a, simplify b, simplify c ]
72+
73+ Can.PCtor _ _ _ alts name args ->
74+ Ctor alts name $
75+ map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args
76+
77+ Can.PList entries ->
78+ foldr cons nil entries
79+
80+ Can.PCons hd tl ->
81+ cons hd (simplify tl)
82+
83+ Can.PAlias subPattern _ ->
84+ simplify subPattern
85+
86+ Can.PInt int ->
87+ Literal (Int int)
88+
89+ Can.PStr str ->
90+ Literal (Str str)
91+
92+ Can.PChr chr ->
93+ Literal (Chr chr)
94+
95+
96+cons :: Can.Pattern -> Pattern -> Pattern
97+cons hd tl =
98+ Ctor listAlts consName [ simplify hd, tl ]
99+
100+
101+{-# NOINLINE nil #-}
102+nil :: Pattern
103+nil =
104+ Ctor listAlts nilName []
105+
106+
107+
108+-- ALTS
109+
110+
111+{-# NOINLINE unitAlts #-}
112+unitAlts :: Can.CtorAlts
113+unitAlts =
114+ Can.toAlts [ Can.CtorAlt unitName 0 ]
115+
116+
117+{-# NOINLINE pairAlts #-}
118+pairAlts :: Can.CtorAlts
119+pairAlts =
120+ Can.toAlts [ Can.CtorAlt pairName 2 ]
121+
122+
123+{-# NOINLINE tripleAlts #-}
124+tripleAlts :: Can.CtorAlts
125+tripleAlts =
126+ Can.toAlts [ Can.CtorAlt tripleName 3 ]
127+
128+
129+{-# NOINLINE listAlts #-}
130+listAlts :: Can.CtorAlts
131+listAlts =
132+ Can.toAlts [ Can.CtorAlt consName 2, Can.CtorAlt nilName 0 ]
133+
134+
135+{-# NOINLINE unitName #-}
136+unitName :: N.Name
137+unitName = "#0"
138+
139+
140+{-# NOINLINE pairName #-}
141+pairName :: N.Name
142+pairName = "#2"
143+
144+
145+{-# NOINLINE tripleName #-}
146+tripleName :: N.Name
147+tripleName = "#3"
148+
149+
150+{-# NOINLINE consName #-}
151+consName :: N.Name
152+consName = "::"
153+
154+
155+{-# NOINLINE nilName #-}
156+nilName :: N.Name
157+nilName = "[]"
158+
159+
160+
161+-- ERROR
162+
163+
164+data Error
165+ = Incomplete R.Region Context [Pattern]
166+ | Redundant R.Region R.Region Int
167+
168+
169+data Context
170+ = BadArg
171+ | BadDestruct
172+ | BadCase
173+
174+
175+
176+-- CHECK
177+
178+
179+check :: Can.Module -> Either [Error] ()
180+check (Can.Module _ _ _ decls _ _ _ _) =
181+ case checkDecls decls [] of
182+ [] ->
183+ Right ()
184+
185+ errors ->
186+ Left errors
187+
188+
189+
190+-- CHECK DECLS
191+
192+
193+checkDecls :: Can.Decls -> [Error] -> [Error]
194+checkDecls decls errors =
195+ case decls of
196+ Can.Declare def subDecls ->
197+ checkDef def $ checkDecls subDecls errors
198+
199+ Can.DeclareRec defs subDecls ->
200+ foldr checkDef (checkDecls subDecls errors) defs
201+
202+ Can.SaveTheEnvironment ->
203+ errors
204+
205+
206+
207+-- CHECK DEFS
208+
209+
210+checkDef :: Can.Def -> [Error] -> [Error]
211+checkDef def errors =
212+ case def of
213+ Can.Def _ args _ body ->
214+ foldr checkArg (checkExpr body errors) args
215+
216+ Can.TypedDef _ _ args _ body _ ->
217+ foldr checkTypedArg (checkExpr body errors) args
218+
219+
220+checkArg :: Can.Arg -> [Error] -> [Error]
221+checkArg (Can.Arg _ pattern@(A.At region _)) errors =
222+ checkPatterns region BadArg [pattern] errors
223+
224+
225+checkTypedArg :: Can.TypedArg -> [Error] -> [Error]
226+checkTypedArg (Can.TypedArg _ _ pattern@(A.At region _)) errors =
227+ checkPatterns region BadArg [pattern] errors
228+
229+
230+
231+-- CHECK EXPRESSIONS
232+
233+
234+checkExpr :: Can.Expr -> [Error] -> [Error]
235+checkExpr (A.At region expression) errors =
67 case expression of
236 case expression of
68− C.Literal _ ->
237+ Can.VarLocal _ ->
69− Result.ok ()
238+ errors
239+
240+ Can.VarTopLevel _ _ ->
241+ errors
242+
243+ Can.VarKernel _ _ ->
244+ errors
245+
246+ Can.VarForeign _ _ _ ->
247+ errors
248+
249+ Can.VarOperator _ _ _ _ ->
250+ errors
251+
252+ Can.Chr _ ->
253+ errors
254+
255+ Can.Str _ ->
256+ errors
257+
258+ Can.Int _ ->
259+ errors
260+
261+ Can.Float _ ->
262+ errors
70
263
71− C.Var _ ->
264+ Can.List entries ->
72− Result.ok ()
265+ foldr checkExpr errors entries
73
266
74− C.List listExprs ->
267+ Can.Negate expr ->
75− F.traverse_ go listExprs
268+ checkExpr expr errors
76
269
77− C.Binop _ leftExpr rightExpr ->
270+ Can.Binop _ _ _ _ left right ->
78− go2 leftExpr rightExpr
271+ checkExpr left $
272+ checkExpr right errors
79
273
80− C.Lambda pattern@(A.A patRegion _) body ->
274+ Can.Lambda args _ body ->
81− checkPatterns arityDict patRegion Error.Arg [pattern]
275+ foldr checkArg (checkExpr body errors) args
82− <* go body
83
276
84− C.App func arg ->
277+ Can.Call func args ->
85− go2 func arg
278+ checkExpr func $ foldr checkExpr errors args
86
279
87− C.If branches finally ->
280+ Can.If branches finally ->
88− F.traverse_ (uncurry go2) branches
281+ foldr checkIfBranch (checkExpr finally errors) branches
89− <* go finally
90
282
91− C.Let defs body ->
283+ Can.Let def body ->
92− go body
284+ checkDef def $ checkExpr body errors
93− <* F.traverse_ goDef defs
94− where
95− goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
96− checkPatterns arityDict patRegion Error.LetBound [pattern]
97− <* go expr
98
285
99− C.Case expr branches ->
286+ Can.LetRec defs body ->
100− go expr
287+ foldr checkDef (checkExpr body errors) defs
101− <* checkPatterns arityDict region Error.Case (map fst branches)
102− <* F.traverse_ (go . snd) branches
103
288
104− C.Ctor _ctor exprs ->
289+ Can.LetDestruct pattern@(A.At reg _) _ expr body ->
105− F.traverse_ go exprs
290+ checkPatterns reg BadDestruct [pattern] $
291+ checkExpr expr $ checkExpr body errors
106
292
107− C.Access record _field ->
293+ Can.Case expr branches ->
108− go record
294+ checkExpr expr $ checkCases region branches errors
109
295
110− C.Update record fields ->
296+ Can.Accessor _ ->
111− go record
297+ errors
112− <* F.traverse_ (go . snd) fields
113
298
114− C.Record fields ->
299+ Can.Access record _ ->
115− F.traverse_ (go . snd) fields
300+ checkExpr record errors
116
301
117− C.Cmd _ _ ->
302+ Can.Update record fields ->
118− Result.ok ()
303+ checkExpr record $ Map.foldr checkExpr errors fields
119
304
120− C.Sub _ _ ->
305+ Can.Record fields ->
121− Result.ok ()
306+ Map.foldr checkExpr errors fields
122
307
123− C.OutgoingPort _ _ ->
308+ Can.Unit ->
124− Result.ok ()
309+ errors
125
310
126− C.IncomingPort _ _ ->
311+ Can.Tuple a b maybeC ->
127− Result.ok ()
312+ checkExpr a $
313+ checkExpr b $
314+ case maybeC of
315+ Nothing ->
316+ errors
317+
318+ Just c ->
319+ checkExpr c errors
320+
321+ Can.Shader _ _ _ ->
322+ errors
323+
324+
325+
326+-- CHECK IF BRANCH
327+
328+
329+checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
330+checkIfBranch (condition, branch) errs =
331+ checkExpr condition $ checkExpr branch errs
332+
333+
334+
335+-- CHECK CASE EXPRESSION
128
336
129− C.Program _ _ ->
130− error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
131
337
132− C.SaveEnv _ _ ->
338+checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
133− Result.ok ()
339+checkCases region branches errors =
340+ let
341+ (patterns, newErrors) =
342+ foldr checkCaseBranch ([], errors) branches
343+ in
344+ checkPatterns region BadCase patterns newErrors
345+
134
346
135− C.GLShader _ _ _ ->
347+checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
136− Result.ok ()
348+checkCaseBranch (Can.CaseBranch pattern _ expr) (patterns, errors) =
349+ ( pattern:patterns
350+ , checkExpr expr errors
351+ )
137
352
138
353
139
354
140-- CHECK PATTERNS
355-- CHECK PATTERNS
141
356
142
357
143−checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
358+checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
144−checkPatterns arityDict region origin patterns =
359+checkPatterns region context patterns errors =
145− do matrix <- checkRedundant arityDict region [] patterns
360+ case toNonRedundantRows region patterns of
361+ Left err ->
362+ err:errors
363+
364+ Right matrix ->
146− case isExhaustive arityDict matrix 1 of
365+ case isExhaustive matrix 1 of
147 [] ->
366 [] ->
148− Result.ok ()
367+ errors
149
368
150 badPatterns ->
369 badPatterns ->
151− Result.throw region (Error.Incomplete origin (map head badPatterns))
370+ Incomplete region context (map head badPatterns) : errors
152
371
153
372
154
373
155-- EXHAUSTIVE PATTERNS
374-- EXHAUSTIVE PATTERNS
156
375
157
376
377+-- INVARIANTS:
378+--
379+-- The initial rows "matrix" are all of length 1
380+-- The initial count of items per row "n" is also 1
381+-- The resulting rows are examples of missing patterns
382+--
158−isExhaustive :: ArityDict -> [[Pattern]] -> Int -> [[Pattern]]
383+isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
159−isExhaustive arityDict matrix n =
384+isExhaustive matrix n =
160− case (matrix, n) of
385+ case matrix of
161− ([], _) ->
386+ [] ->
162 [replicate n Anything]
387 [replicate n Anything]
163
388
164− (_, 0) ->
389+ _ ->
390+ if n == 0 then
165− []
391+ []
166−
392+ else
167− (_, _) ->
168 let
393 let
169− ctorSet =
394+ ctors = collectCtors matrix
170− List.foldl' isCompleteHelp Set.empty matrix
395+ numSeen = Map.size ctors
171−
172− actual =
173− Set.size ctorSet
174 in
396 in
175− if actual == 0 then
397+ if numSeen == 0 then
176− (:) Anything
398+ (:) Anything
177− <$> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
399+ <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
400+
401+ else
402+ let alts@(Can.CtorAlts numAlts altList) = snd (Map.findMin ctors) in
403+ if numSeen < numAlts then
404+ (:)
405+ <$> Maybe.mapMaybe (isMissing alts ctors) altList
406+ <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
178
407
179 else
408 else
180 let
409 let
181− (ArityInfo expected info) =
410+ isAltExhaustive (Can.CtorAlt name arity) =
182− getArityInfo (Set.findMin ctorSet) arityDict
411+ recoverCtor alts name arity <$>
412+ isExhaustive
413+ (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
414+ (arity + n - 1)
183 in
415 in
184− if actual < expected then
416+ concatMap isAltExhaustive altList
185− (:)
417+
186− <$> Maybe.mapMaybe (isMissing ctorSet) info
187− <*> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
188−
189− else
190− let
191− isExhaustiveHelp (name, arity) =
192− recoverCtor name arity <$>
193− isExhaustive
194− arityDict
195− (Maybe.mapMaybe (specialize name arity) matrix)
196− (arity + n - 1)
197− in
198− concatMap isExhaustiveHelp info
199−
200−
201−isMissing :: Set.Set Var.Canonical -> (Var.Canonical, Int) -> Maybe Pattern
202−isMissing ctorSet (name, arity) =
203− if Set.member name ctorSet then
204− Nothing
205
418
419+isMissing :: Can.CtorAlts -> Map.Map N.Name a -> Can.CtorAlt -> Maybe Pattern
420+isMissing alts ctors (Can.CtorAlt name arity) =
421+ if Map.member name ctors then
422+ Nothing
206 else
423 else
207− Just (Ctor name (replicate arity Anything))
424+ Just (Ctor alts name (replicate arity Anything))
208
425
209
426
210−recoverCtor :: Var.Canonical -> Int -> [Pattern] -> [Pattern]
427+recoverCtor :: Can.CtorAlts -> N.Name -> Int -> [Pattern] -> [Pattern]
211−recoverCtor name arity patterns =
428+recoverCtor alts name arity patterns =
212 let
429 let
213 (args, rest) =
430 (args, rest) =
214 splitAt arity patterns
431 splitAt arity patterns
215 in
432 in
216− Ctor name args : rest
433+ Ctor alts name args : rest
217
434
218
435
219
436
220-- REDUNDANT PATTERNS
437-- REDUNDANT PATTERNS
221
438
222
439
223−checkRedundant
440+-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
224− :: ArityDict
441+toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
225− -> Region.Region
442+toNonRedundantRows region patterns =
226− -> [[Pattern]]
443+ toSimplifiedUsefulRows region [] patterns
227− -> [Pattern.Canonical]
228− -> Result wrn [[Pattern]]
229−checkRedundant arityDict region checked unchecked =
230− case unchecked of
231− [] ->
232− Result.ok checked
233−
234− nextPattern@(A.A patRegion _) : rest ->
235− let
236− next =
237− [fromCanonicalPattern nextPattern]
238− in
239− if isUseful arityDict checked next then
240− checkRedundant arityDict region (next : checked) rest
241− else
242− Result.throw region (Error.Redundant patRegion (length checked + 1))
243
444
244
445
245−isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
446+-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
246−isUseful arityDict matrix vector =
447+toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
247− case (matrix, vector) of
448+toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
449+ case uncheckedPatterns of
248− ([], _) ->
450+ [] ->
249− True
451+ Right checkedRows
250−
251− (_, []) ->
252− False
253
452
254− (_, firstPattern : patterns) ->
453+ pattern@(A.At region _) : rest ->
255− case firstPattern of
454+ let nextRow = [simplify pattern] in
256− Ctor name args ->
455+ if isUseful checkedRows nextRow then
257− let
456+ toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
258− newMatrix =
457+ else
259− Maybe.mapMaybe (specialize name (length args)) matrix
458+ Left (Redundant overallRegion region (length checkedRows + 1))
260− in
261− isUseful arityDict newMatrix (args ++ patterns)
262
459
263− Anything ->
264− case isComplete arityDict matrix of
265− Nothing ->
266− isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
267−
268− Just arityInfo ->
269− let
270− isUsefulHelp (ctor, arity) =
271− isUseful
272− arityDict
273− (Maybe.mapMaybe (specialize ctor arity) matrix)
274− (replicate arity Anything ++ patterns)
275− in
276− any isUsefulHelp arityInfo
277−
278− Literal literal ->
279− let
280− newMatrix =
281− Maybe.mapMaybe (specializeLiteral literal) matrix
282− in
283− isUseful arityDict newMatrix patterns
284
460
461+-- Check if a new row "vector" is useful given previous rows "matrix"
462+isUseful :: [[Pattern]] -> [Pattern] -> Bool
463+isUseful matrix vector =
464+ case matrix of
465+ [] ->
466+ -- No rows are the same as the new vector! The vector is useful!
467+ True
285
468
469+ _ ->
470+ case vector of
471+ [] ->
472+ -- There is nothing left in the new vector, but we still have
473+ -- rows that match the same things. This is not a useful vector!
474+ False
475+
476+ firstPattern : patterns ->
477+ case firstPattern of
478+ Ctor _ name args ->
479+ -- keep checking rows that start with this Ctor or Anything
480+ isUseful
481+ (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
482+ (args ++ patterns)
483+
484+ Anything ->
485+ -- check if all alts appear in matrix
486+ case isComplete matrix of
487+ No ->
488+ -- This Anything is useful because some Ctors are missing.
489+ -- But what if a previous row has an Anything?
490+ -- If so, this one is not useful.
491+ isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
492+
493+ Yes alts ->
494+ -- All Ctors are covered, so this Anything is not needed for any
495+ -- of those. But what if some of those Ctors have subpatterns
496+ -- that make them less general? If so, this actually is useful!
497+ let
498+ isUsefulAlt (Can.CtorAlt ctor arity) =
499+ isUseful
500+ (Maybe.mapMaybe (specializeRowByCtor ctor arity) matrix)
501+ (replicate arity Anything ++ patterns)
502+ in
503+ any isUsefulAlt alts
504+
505+ Literal literal ->
506+ -- keep checking rows that start with this Literal or Anything
507+ isUseful
508+ (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
509+ patterns
510+
511+
512+-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
513+specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]
514+specializeRowByCtor ctorName arity row =
515+ case row of
516+ Ctor _ name args : patterns ->
517+ if name == ctorName then
518+ Just (args ++ patterns)
519+ else
520+ Nothing
286
521
287−-- SPECIALIZE MATRICES
522+ Anything : patterns ->
523+ Just (replicate arity Anything ++ patterns)
288
524
525+ Literal _ : _ ->
526+ error $
527+ "Compiler bug! After type checking, constructors and literals\
528+ \ should never align in pattern match exhaustiveness checks."
289
529
290−specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
291−specialize ctorName arity row =
292− case row of
293 [] ->
530 [] ->
294 error "Compiler error! Empty matrices should not get specialized."
531 error "Compiler error! Empty matrices should not get specialized."
295
532
296− firstPattern : patterns ->
297− case firstPattern of
298− Ctor name args ->
299− if name == ctorName then Just (args ++ patterns) else Nothing
300
533
301− Anything ->
534+-- INVARIANT: (length row == N) ==> (length result == N-1)
535+specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
536+specializeRowByLiteral literal row =
537+ case row of
538+ Literal lit : patterns ->
539+ if lit == literal then
302− Just (replicate arity Anything ++ patterns)
540+ Just patterns
541+ else
542+ Nothing
303
543
304− Literal _ ->
544+ Anything : patterns ->
305− error $
545+ Just patterns
306− "Compiler bug! After type checking, constructors and literals\
307− \ should never align in pattern match exhaustiveness checks."
308
546
547+ Ctor _ _ _ : _ ->
548+ error $
549+ "Compiler bug! After type checking, constructors and literals\
550+ \ should never align in pattern match exhaustiveness checks."
309
551
310−specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
311−specializeLiteral literal row =
312− case row of
313 [] ->
552 [] ->
314 error "Compiler error! Empty matrices should not get specialized."
553 error "Compiler error! Empty matrices should not get specialized."
315
554
316− firstPattern : patterns ->
317− case firstPattern of
318− Literal lit ->
319− if lit == literal then Just patterns else Nothing
320−
321− Anything ->
322− Just patterns
323−
324− Ctor _ _ ->
325− error $
326− "Compiler bug! After type checking, constructors and literals\
327− \ should never align in pattern match exhaustiveness checks."
328
555
329−
556+-- INVARIANT: (length row == N) ==> (length result == N-1)
330−toDefault :: [Pattern] -> Maybe [Pattern]
557+specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
331−toDefault row =
558+specializeRowByAnything row =
332 case row of
559 case row of
333 [] ->
560 [] ->
334 Nothing
561 Nothing
335
562
336− Ctor _ _ : _ ->
563+ Ctor _ _ _ : _ ->
337 Nothing
564 Nothing
338
565
339 Anything : patterns ->
566 Anything : patterns ->
@@ -347,108 +574,38 @@ toDefault row =
347-- ALL CONSTRUCTORS ARE PRESENT?
574-- ALL CONSTRUCTORS ARE PRESENT?
348
575
349
576
350−isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
577+data Complete
351−isComplete arityDict matrix =
578+ = Yes [Can.CtorAlt]
352− let
579+ | No
353− ctorSet =
354− List.foldl' isCompleteHelp Set.empty matrix
355−
356− actual =
357− Set.size ctorSet
358− in
359− if actual == 0 then
360− Nothing
361−
362− else
363− let
364− (ArityInfo expected info) =
365− getArityInfo (Set.findMin ctorSet) arityDict
366− in
367− if expected == actual then Just info else Nothing
368−
369−
370−isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
371−isCompleteHelp ctors row =
372− case row of
373− Ctor name _ : _ ->
374− Set.insert name ctors
375−
376− _ ->
377− ctors
378−
379−
380−
381−-- ARITY DICT
382−
383−
384−type ArityDict =
385− Map.Map Var.Home (Map.Map Text ArityInfo)
386−
387−
388−data ArityInfo =
389− ArityInfo
390− { _size :: !Int
391− , _info :: [(Var.Canonical, Int)]
392− }
393
580
394
581
395−toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
582+isComplete :: [[Pattern]] -> Complete
396−toArityDict interfaces localName localUnions =
583+isComplete matrix =
397− interfaces
398− |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
399− |> Map.mapKeysMonotonic Var.Module
400− |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
401− |> Map.union builtinDict
402−
403−
404−builtinDict :: ArityDict
405−builtinDict =
406 let
584 let
407− listInfo =
585+ ctors = collectCtors matrix
408− ArityInfo 2 [ (Var.cons, 2), (Var.nil, 0) ]
586+ numSeen = Map.size ctors
409−
410− boolInfo =
411− ArityInfo 2 [ (Var.true, 0), (Var.false, 0) ]
412 in
587 in
413− Map.singleton Var.BuiltIn $ Map.fromList $
588+ if numSeen == 0 then
414− [ ("::", listInfo)
589+ No
415− , ("[]", listInfo)
590+ else
416− , ("True", boolInfo)
591+ let (Can.CtorAlts numAlts alts) = snd (Map.findMin ctors) in
417− , ("False", boolInfo)
592+ if numSeen == numAlts then Yes alts else No
418− ]
419− ++ map makeTupleInfo [0..8]
420
593
421
594
422−makeTupleInfo :: Int -> ( Text, ArityInfo )
423−makeTupleInfo n =
424− ( Help.makeTuple n, ArityInfo 1 [ (Var.tuple n, n) ] )
425
595
596+-- COLLECT CTORS
426
597
427−toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo
428−toArityEntry name unions =
429− Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
430
598
599+collectCtors :: [[Pattern]] -> Map.Map N.Name Can.CtorAlts
600+collectCtors matrix =
601+ List.foldl' collectCtorsHelp Map.empty matrix
431
602
432−toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo Text -> [(Text, ArityInfo)]
433−toArityEntryHelp name (_tvars, ctors) =
434− let
435− arityInfo =
436− ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
437− in
438− map (second (\_ -> arityInfo)) ctors
439
603
604+collectCtorsHelp :: Map.Map N.Name Can.CtorAlts -> [Pattern] -> Map.Map N.Name Can.CtorAlts
605+collectCtorsHelp ctors row =
606+ case row of
607+ Ctor info name _ : _ ->
608+ Map.insert name info ctors
440
609
441−getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
610+ _ ->
442−getArityInfo var@(Var.Canonical home name) arityDict =
611+ ctors
443− case Map.lookup name =<< Map.lookup home arityDict of
444− Just arityInfo ->
445− arityInfo
446−
447− Nothing ->
448− if Help.isTuple name then
449− ArityInfo 1 [ (var, read (drop 6 (Text.unpack name))) ]
450− else
451− error
452− "Since the Nitpick phase happens after canonicalization and type\
453− \ inference, it is impossible that a pattern in a case cannot be\
454− \ found."