@@ -1,6 +1,13 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Nitpick.PatternMatches (patternMatches) where
3+module Nitpick.PatternMatches
4+ ( check
5+ , Error(..)
6+ , Context(..)
7+ , Pattern(..)
8+ )
9+ where
10+
411
512{- The algorithm used here comes from "Warnings for Pattern Matching"
613by Luc Maranget. Check it out for more information!
@@ -9,331 +16,551 @@ http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
916
1017-}
1118
12−import Control.Arrow ((***), second)
13−import qualified Data.Foldable as F
1419import qualified Data.List as List
1520import qualified Data.Map as Map
1621import qualified Data.Maybe as Maybe
17−import qualified Data.Set as Set
1822import qualified Data.Text as Text
19−import Data.Text (Text)
20−
21−import qualified AST.Expression.Canonical as C
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
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
23+
24+import qualified AST.Canonical as Can
25+import qualified Elm.Name as N
3126import qualified Reporting.Annotation as A
32−import qualified Reporting.Error.Pattern as Error
33−import qualified Reporting.Region as Region
34−import qualified Reporting.Result as Result
27+import qualified Reporting.Region as R
3528
3629
3730
38−-- NITPICK PATTERN MATCHES
31+-- PATTERN
3932
4033
41−type Result warning a =
42− Result.Result () warning Error.Error a
34+data Pattern
35+ = Anything
36+ | Literal Literal
37+ | Ctor Can.CtorAlts N.Name [Pattern]
38+ deriving (Eq)
4339
4440
45−patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
46−patternMatches interfaces (Module.Module name info) =
47− let
48− arityDict =
49− toArityDict interfaces name (Module.unions info)
41+data Literal
42+ = Chr Text.Text
43+ | Str Text.Text
44+ | Int Int
45+ deriving (Eq)
5046
51− variantDict =
52− Map.map (Map.map _size) arityDict
53− in
54− pure variantDict
55− <* checkExpression arityDict (Module.program info)
5647
5748
58−checkExpression :: ArityDict -> C.Expr -> Result wrn ()
59−checkExpression arityDict (A.A region expression) =
60− let
61− go =
62− checkExpression arityDict
49+-- CREATE SIMPLIFIED PATTERNS
6350
64− go2 a b =
65− go a <* go b
66− in
51+
52+simplify :: Can.Pattern -> Pattern
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 =
67236 case expression of
68− C.Literal _ ->
69− Result.ok ()
237+ Can.VarLocal _ ->
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
70263
71− C.Var _ ->
72− Result.ok ()
264+ Can.List entries ->
265+ foldr checkExpr errors entries
73266
74− C.List listExprs ->
75− F.traverse_ go listExprs
267+ Can.Negate expr ->
268+ checkExpr expr errors
76269
77− C.Binop _ leftExpr rightExpr ->
78− go2 leftExpr rightExpr
270+ Can.Binop _ _ _ _ left right ->
271+ checkExpr left $
272+ checkExpr right errors
79273
80− C.Lambda pattern@(A.A patRegion _) body ->
81− checkPatterns arityDict patRegion Error.Arg [pattern]
82− <* go body
274+ Can.Lambda args _ body ->
275+ foldr checkArg (checkExpr body errors) args
83276
84− C.App func arg ->
85− go2 func arg
277+ Can.Call func args ->
278+ checkExpr func $ foldr checkExpr errors args
86279
87− C.If branches finally ->
88− F.traverse_ (uncurry go2) branches
89− <* go finally
280+ Can.If branches finally ->
281+ foldr checkIfBranch (checkExpr finally errors) branches
90282
91− C.Let defs body ->
92− go body
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
283+ Can.Let def body ->
284+ checkDef def $ checkExpr body errors
98285
99− C.Case expr branches ->
100− go expr
101− <* checkPatterns arityDict region Error.Case (map fst branches)
102− <* F.traverse_ (go . snd) branches
286+ Can.LetRec defs body ->
287+ foldr checkDef (checkExpr body errors) defs
103288
104− C.Ctor _ctor exprs ->
105− F.traverse_ go exprs
289+ Can.LetDestruct pattern@(A.At reg _) _ expr body ->
290+ checkPatterns reg BadDestruct [pattern] $
291+ checkExpr expr $ checkExpr body errors
106292
107− C.Access record _field ->
108− go record
293+ Can.Case expr branches ->
294+ checkExpr expr $ checkCases region branches errors
109295
110− C.Update record fields ->
111− go record
112− <* F.traverse_ (go . snd) fields
296+ Can.Accessor _ ->
297+ errors
113298
114− C.Record fields ->
115− F.traverse_ (go . snd) fields
299+ Can.Access record _ ->
300+ checkExpr record errors
116301
117− C.Cmd _ _ ->
118− Result.ok ()
302+ Can.Update record fields ->
303+ checkExpr record $ Map.foldr checkExpr errors fields
119304
120− C.Sub _ _ ->
121− Result.ok ()
305+ Can.Record fields ->
306+ Map.foldr checkExpr errors fields
122307
123− C.OutgoingPort _ _ ->
124− Result.ok ()
308+ Can.Unit ->
309+ errors
125310
126− C.IncomingPort _ _ ->
127− Result.ok ()
311+ Can.Tuple a b maybeC ->
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
128336
129− C.Program _ _ ->
130− error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
131337
132− C.SaveEnv _ _ ->
133− Result.ok ()
338+checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
339+checkCases region branches errors =
340+ let
341+ (patterns, newErrors) =
342+ foldr checkCaseBranch ([], errors) branches
343+ in
344+ checkPatterns region BadCase patterns newErrors
345+
134346
135− C.GLShader _ _ _ ->
136− Result.ok ()
347+checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
348+checkCaseBranch (Can.CaseBranch pattern _ expr) (patterns, errors) =
349+ ( pattern:patterns
350+ , checkExpr expr errors
351+ )
137352
138353
139354
140355-- CHECK PATTERNS
141356
142357
143−checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
144−checkPatterns arityDict region origin patterns =
145− do matrix <- checkRedundant arityDict region [] patterns
146− case isExhaustive arityDict matrix 1 of
358+checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
359+checkPatterns region context patterns errors =
360+ case toNonRedundantRows region patterns of
361+ Left err ->
362+ err:errors
363+
364+ Right matrix ->
365+ case isExhaustive matrix 1 of
147366 [] ->
148− Result.ok ()
367+ errors
149368
150369 badPatterns ->
151− Result.throw region (Error.Incomplete origin (map head badPatterns))
370+ Incomplete region context (map head badPatterns) : errors
152371
153372
154373
155374-- EXHAUSTIVE PATTERNS
156375
157376
158−isExhaustive :: ArityDict -> [[Pattern]] -> Int -> [[Pattern]]
159−isExhaustive arityDict matrix n =
160− case (matrix, n) of
161− ([], _) ->
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+--
383+isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
384+isExhaustive matrix n =
385+ case matrix of
386+ [] ->
162387 [replicate n Anything]
163388
164− (_, 0) ->
165− []
166−
167− (_, _) ->
389+ _ ->
390+ if n == 0 then
391+ []
392+ else
168393 let
169− ctorSet =
170− List.foldl' isCompleteHelp Set.empty matrix
171−
172− actual =
173− Set.size ctorSet
394+ ctors = collectCtors matrix
395+ numSeen = Map.size ctors
174396 in
175− if actual == 0 then
176− (:) Anything
177− <$> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
397+ if numSeen == 0 then
398+ (:) Anything
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)
178407
179408 else
180409 let
181− (ArityInfo expected info) =
182− getArityInfo (Set.findMin ctorSet) arityDict
410+ isAltExhaustive (Can.CtorAlt name arity) =
411+ recoverCtor alts name arity <$>
412+ isExhaustive
413+ (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
414+ (arity + n - 1)
183415 in
184− if actual < expected then
185− (:)
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
416+ concatMap isAltExhaustive altList
417+
205418
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
206423 else
207− Just (Ctor name (replicate arity Anything))
424+ Just (Ctor alts name (replicate arity Anything))
208425
209426
210−recoverCtor :: Var.Canonical -> Int -> [Pattern] -> [Pattern]
211−recoverCtor name arity patterns =
427+recoverCtor :: Can.CtorAlts -> N.Name -> Int -> [Pattern] -> [Pattern]
428+recoverCtor alts name arity patterns =
212429 let
213430 (args, rest) =
214431 splitAt arity patterns
215432 in
216− Ctor name args : rest
433+ Ctor alts name args : rest
217434
218435
219436
220437-- REDUNDANT PATTERNS
221438
222439
223−checkRedundant
224− :: ArityDict
225− -> Region.Region
226− -> [[Pattern]]
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))
440+-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
441+toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
442+toNonRedundantRows region patterns =
443+ toSimplifiedUsefulRows region [] patterns
243444
244445
245−isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
246−isUseful arityDict matrix vector =
247− case (matrix, vector) of
248− ([], _) ->
249− True
250−
251− (_, []) ->
252− False
446+-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
447+toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
448+toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
449+ case uncheckedPatterns of
450+ [] ->
451+ Right checkedRows
253452
254− (_, firstPattern : patterns) ->
255− case firstPattern of
256− Ctor name args ->
257− let
258− newMatrix =
259− Maybe.mapMaybe (specialize name (length args)) matrix
260− in
261− isUseful arityDict newMatrix (args ++ patterns)
453+ pattern@(A.At region _) : rest ->
454+ let nextRow = [simplify pattern] in
455+ if isUseful checkedRows nextRow then
456+ toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
457+ else
458+ Left (Redundant overallRegion region (length checkedRows + 1))
262459
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
284460
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
285468
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
286521
287−-- SPECIALIZE MATRICES
522+ Anything : patterns ->
523+ Just (replicate arity Anything ++ patterns)
288524
525+ Literal _ : _ ->
526+ error $
527+ "Compiler bug! After type checking, constructors and literals\
528+ \ should never align in pattern match exhaustiveness checks."
289529
290−specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
291−specialize ctorName arity row =
292− case row of
293530 [] ->
294531 error "Compiler error! Empty matrices should not get specialized."
295532
296− firstPattern : patterns ->
297− case firstPattern of
298− Ctor name args ->
299− if name == ctorName then Just (args ++ patterns) else Nothing
300533
301− Anything ->
302− Just (replicate arity Anything ++ patterns)
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
540+ Just patterns
541+ else
542+ Nothing
303543
304− Literal _ ->
305− error $
306− "Compiler bug! After type checking, constructors and literals\
307− \ should never align in pattern match exhaustiveness checks."
544+ Anything : patterns ->
545+ Just patterns
308546
547+ Ctor _ _ _ : _ ->
548+ error $
549+ "Compiler bug! After type checking, constructors and literals\
550+ \ should never align in pattern match exhaustiveness checks."
309551
310−specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
311−specializeLiteral literal row =
312− case row of
313552 [] ->
314553 error "Compiler error! Empty matrices should not get specialized."
315554
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."
328555
329−
330−toDefault :: [Pattern] -> Maybe [Pattern]
331−toDefault row =
556+-- INVARIANT: (length row == N) ==> (length result == N-1)
557+specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
558+specializeRowByAnything row =
332559 case row of
333560 [] ->
334561 Nothing
335562
336− Ctor _ _ : _ ->
563+ Ctor _ _ _ : _ ->
337564 Nothing
338565
339566 Anything : patterns ->
@@ -347,108 +574,38 @@ toDefault row =
347574-- ALL CONSTRUCTORS ARE PRESENT?
348575
349576
350−isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
351−isComplete arityDict matrix =
352− let
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− }
577+data Complete
578+ = Yes [Can.CtorAlt]
579+ | No
393580
394581
395−toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
396−toArityDict interfaces localName localUnions =
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 =
582+isComplete :: [[Pattern]] -> Complete
583+isComplete matrix =
406584 let
407− listInfo =
408− ArityInfo 2 [ (Var.cons, 2), (Var.nil, 0) ]
409−
410− boolInfo =
411− ArityInfo 2 [ (Var.true, 0), (Var.false, 0) ]
585+ ctors = collectCtors matrix
586+ numSeen = Map.size ctors
412587 in
413− Map.singleton Var.BuiltIn $ Map.fromList $
414− [ ("::", listInfo)
415− , ("[]", listInfo)
416− , ("True", boolInfo)
417− , ("False", boolInfo)
418− ]
419− ++ map makeTupleInfo [0..8]
588+ if numSeen == 0 then
589+ No
590+ else
591+ let (Can.CtorAlts numAlts alts) = snd (Map.findMin ctors) in
592+ if numSeen == numAlts then Yes alts else No
420593
421594
422−makeTupleInfo :: Int -> ( Text, ArityInfo )
423−makeTupleInfo n =
424− ( Help.makeTuple n, ArityInfo 1 [ (Var.tuple n, n) ] )
425595
596+-- COLLECT CTORS
426597
427−toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo
428−toArityEntry name unions =
429− Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
430598
599+collectCtors :: [[Pattern]] -> Map.Map N.Name Can.CtorAlts
600+collectCtors matrix =
601+ List.foldl' collectCtorsHelp Map.empty matrix
431602
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
439603
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
440609
441−getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
442−getArityInfo var@(Var.Canonical home name) arityDict =
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."
610+ _ ->
611+ ctors