git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Nitpick/PatternMatches.hs
652 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Nitpick.PatternMatches
4 ( check
5 , Error(..)
6 , Context(..)
7 , Pattern(..)
8 , Literal(..)
9 )
10 where
13{- The algorithm used here comes from "Warnings for Pattern Matching"
14by Luc Maranget. Check it out for more information!
16http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
18-}
20import qualified Data.List as List
21import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
23import qualified Data.Name as Name
24import qualified Data.Utf8 as Utf8
26import qualified AST.Canonical as Can
27import qualified Data.Index as Index
28import qualified Elm.ModuleName as ModuleName
29import qualified Reporting.Annotation as A
33-- PATTERN
36data Pattern
37 = Anything
38 | Literal Literal
39 | Ctor Can.Union Name.Name [Pattern]
42data Literal
43 = Chr Utf8.String
44 | Str Utf8.String
45 | Int Int
46 deriving (Eq)
50-- CREATE SIMPLIFIED PATTERNS
53simplify :: Can.Pattern -> Pattern
54simplify (A.At _ pattern) =
55 case pattern of
56 Can.PAnything ->
57 Anything
59 Can.PVar _ ->
60 Anything
62 Can.PRecord _ ->
63 Anything
65 Can.PUnit ->
66 Ctor unit unitName []
68 Can.PTuple a b Nothing ->
69 Ctor pair pairName [ simplify a, simplify b ]
71 Can.PTuple a b (Just c) ->
72 Ctor triple tripleName [ simplify a, simplify b, simplify c ]
74 Can.PCtor _ _ union name _ args ->
75 Ctor union name $
76 map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args
78 Can.PList entries ->
79 foldr cons nil entries
81 Can.PCons hd tl ->
82 cons hd (simplify tl)
84 Can.PAlias subPattern _ ->
85 simplify subPattern
87 Can.PInt int ->
88 Literal (Int int)
90 Can.PStr str ->
91 Literal (Str str)
93 Can.PChr chr ->
94 Literal (Chr chr)
96 Can.PBool union bool ->
97 Ctor union (if bool then Name.true else Name.false) []
100cons :: Can.Pattern -> Pattern -> Pattern
101cons hd tl =
102 Ctor list consName [ simplify hd, tl ]
105{-# NOINLINE nil #-}
106nil :: Pattern
107nil =
108 Ctor list nilName []
112-- BUILT-IN UNIONS
115{-# NOINLINE unit #-}
116unit :: Can.Union
117unit =
118 let
119 ctor =
120 Can.Ctor unitName Index.first 0 []
121 in
122 Can.Union [] [ ctor ] 1 Can.Normal
125{-# NOINLINE pair #-}
126pair :: Can.Union
127pair =
128 let
129 ctor =
130 Can.Ctor pairName Index.first 2 [Can.TVar "a", Can.TVar "b"]
131 in
132 Can.Union ["a","b"] [ ctor ] 1 Can.Normal
135{-# NOINLINE triple #-}
136triple :: Can.Union
137triple =
138 let
139 ctor =
140 Can.Ctor tripleName Index.first 3 [Can.TVar "a", Can.TVar "b", Can.TVar "c"]
141 in
142 Can.Union ["a","b","c"] [ ctor ] 1 Can.Normal
145{-# NOINLINE list #-}
146list :: Can.Union
147list =
148 let
149 nilCtor =
150 Can.Ctor nilName Index.first 0 []
152 consCtor =
153 Can.Ctor consName Index.second 2
154 [ Can.TVar "a"
155 , Can.TType ModuleName.list Name.list [Can.TVar "a"]
156 ]
157 in
158 Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal
161{-# NOINLINE unitName #-}
162unitName :: Name.Name
163unitName = "#0"
166{-# NOINLINE pairName #-}
167pairName :: Name.Name
168pairName = "#2"
171{-# NOINLINE tripleName #-}
172tripleName :: Name.Name
173tripleName = "#3"
176{-# NOINLINE consName #-}
177consName :: Name.Name
178consName = "::"
181{-# NOINLINE nilName #-}
182nilName :: Name.Name
183nilName = "[]"
187-- ERROR
190data Error
191 = Incomplete A.Region Context [Pattern]
192 | Redundant A.Region A.Region Int
195data Context
196 = BadArg
197 | BadDestruct
198 | BadCase
202-- CHECK
205check :: Can.Module -> Either [Error] ()
206check (Can.Module _ _ decls _ _ _ _) =
207 case checkDecls decls [] of
208 [] ->
209 Right ()
211 errors ->
212 Left errors
216-- CHECK DECLS
219checkDecls :: Can.Decls -> [Error] -> [Error]
220checkDecls decls errors =
221 case decls of
222 Can.Declare def subDecls ->
223 checkDef def $ checkDecls subDecls errors
225 Can.DeclareRec def defs subDecls ->
226 checkDef def (foldr checkDef (checkDecls subDecls errors) defs)
228 Can.SaveTheEnvironment ->
229 errors
233-- CHECK DEFS
236checkDef :: Can.Def -> [Error] -> [Error]
237checkDef def errors =
238 case def of
239 Can.Def _ args body ->
240 foldr checkArg (checkExpr body errors) args
242 Can.TypedDef _ _ args body _ ->
243 foldr checkTypedArg (checkExpr body errors) args
246checkArg :: Can.Pattern -> [Error] -> [Error]
247checkArg pattern@(A.At region _) errors =
248 checkPatterns region BadArg [pattern] errors
251checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
252checkTypedArg (pattern@(A.At region _), _) errors =
253 checkPatterns region BadArg [pattern] errors
257-- CHECK EXPRESSIONS
260checkExpr :: Can.Expr -> [Error] -> [Error]
261checkExpr (A.At region expression) errors =
262 case expression of
263 Can.VarLocal _ ->
264 errors
266 Can.VarTopLevel _ _ ->
267 errors
269 Can.VarKernel _ _ ->
270 errors
272 Can.VarForeign _ _ _ ->
273 errors
275 Can.VarCtor _ _ _ _ _ ->
276 errors
278 Can.VarDebug _ _ _ ->
279 errors
281 Can.VarOperator _ _ _ _ ->
282 errors
284 Can.Chr _ ->
285 errors
287 Can.Str _ ->
288 errors
290 Can.Int _ ->
291 errors
293 Can.Float _ ->
294 errors
296 Can.List entries ->
297 foldr checkExpr errors entries
299 Can.Negate expr ->
300 checkExpr expr errors
302 Can.Binop _ _ _ _ left right ->
303 checkExpr left $
304 checkExpr right errors
306 Can.Lambda args body ->
307 foldr checkArg (checkExpr body errors) args
309 Can.Call func args ->
310 checkExpr func $ foldr checkExpr errors args
312 Can.If branches finally ->
313 foldr checkIfBranch (checkExpr finally errors) branches
315 Can.Let def body ->
316 checkDef def $ checkExpr body errors
318 Can.LetRec defs body ->
319 foldr checkDef (checkExpr body errors) defs
321 Can.LetDestruct pattern@(A.At reg _) expr body ->
322 checkPatterns reg BadDestruct [pattern] $
323 checkExpr expr $ checkExpr body errors
325 Can.Case expr branches ->
326 checkExpr expr $ checkCases region branches errors
328 Can.Accessor _ ->
329 errors
331 Can.Access record _ ->
332 checkExpr record errors
334 Can.Update _ record fields ->
335 checkExpr record $ Map.foldr checkField errors fields
337 Can.Record fields ->
338 Map.foldr checkExpr errors fields
340 Can.Unit ->
341 errors
343 Can.Tuple a b maybeC ->
344 checkExpr a $
345 checkExpr b $
346 case maybeC of
347 Nothing ->
348 errors
350 Just c ->
351 checkExpr c errors
353 Can.Shader _ _ ->
354 errors
358-- CHECK FIELD
361checkField :: Can.FieldUpdate -> [Error] -> [Error]
362checkField (Can.FieldUpdate _ expr) errors =
363 checkExpr expr errors
367-- CHECK IF BRANCH
370checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
371checkIfBranch (condition, branch) errs =
372 checkExpr condition $ checkExpr branch errs
376-- CHECK CASE EXPRESSION
379checkCases :: A.Region -> [Can.CaseBranch] -> [Error] -> [Error]
380checkCases region branches errors =
381 let
382 (patterns, newErrors) =
383 foldr checkCaseBranch ([], errors) branches
384 in
385 checkPatterns region BadCase patterns newErrors
388checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
389checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
390 ( pattern:patterns
391 , checkExpr expr errors
392 )
396-- CHECK PATTERNS
399checkPatterns :: A.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
400checkPatterns region context patterns errors =
401 case toNonRedundantRows region patterns of
402 Left err ->
403 err:errors
405 Right matrix ->
406 case isExhaustive matrix 1 of
407 [] ->
408 errors
410 badPatterns ->
411 Incomplete region context (map head badPatterns) : errors
415-- EXHAUSTIVE PATTERNS
418-- INVARIANTS:
419--
420-- The initial rows "matrix" are all of length 1
421-- The initial count of items per row "n" is also 1
422-- The resulting rows are examples of missing patterns
423--
424isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
425isExhaustive matrix n =
426 case matrix of
427 [] ->
428 [replicate n Anything]
430 _ ->
431 if n == 0 then
432 []
433 else
434 let
435 ctors = collectCtors matrix
436 numSeen = Map.size ctors
437 in
438 if numSeen == 0 then
439 (:) Anything
440 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
442 else
443 let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in
444 if numSeen < numAlts then
445 (:)
446 <$> Maybe.mapMaybe (isMissing alts ctors) altList
447 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
449 else
450 let
451 isAltExhaustive (Can.Ctor name _ arity _) =
452 recoverCtor alts name arity <$>
453 isExhaustive
454 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
455 (arity + n - 1)
456 in
457 concatMap isAltExhaustive altList
460isMissing :: Can.Union -> Map.Map Name.Name a -> Can.Ctor -> Maybe Pattern
461isMissing union ctors (Can.Ctor name _ arity _) =
462 if Map.member name ctors then
463 Nothing
464 else
465 Just (Ctor union name (replicate arity Anything))
468recoverCtor :: Can.Union -> Name.Name -> Int -> [Pattern] -> [Pattern]
469recoverCtor union name arity patterns =
470 let
471 (args, rest) =
472 splitAt arity patterns
473 in
474 Ctor union name args : rest
478-- REDUNDANT PATTERNS
481-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
482toNonRedundantRows :: A.Region -> [Can.Pattern] -> Either Error [[Pattern]]
483toNonRedundantRows region patterns =
484 toSimplifiedUsefulRows region [] patterns
487-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
488toSimplifiedUsefulRows :: A.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
489toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
490 case uncheckedPatterns of
491 [] ->
492 Right checkedRows
494 pattern@(A.At region _) : rest ->
495 let nextRow = [simplify pattern] in
496 if isUseful checkedRows nextRow then
497 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
498 else
499 Left (Redundant overallRegion region (length checkedRows + 1))
502-- Check if a new row "vector" is useful given previous rows "matrix"
503isUseful :: [[Pattern]] -> [Pattern] -> Bool
504isUseful matrix vector =
505 case matrix of
506 [] ->
507 -- No rows are the same as the new vector! The vector is useful!
508 True
510 _ ->
511 case vector of
512 [] ->
513 -- There is nothing left in the new vector, but we still have
514 -- rows that match the same things. This is not a useful vector!
515 False
517 firstPattern : patterns ->
518 case firstPattern of
519 Ctor _ name args ->
520 -- keep checking rows that start with this Ctor or Anything
521 isUseful
522 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
523 (args ++ patterns)
525 Anything ->
526 -- check if all alts appear in matrix
527 case isComplete matrix of
528 No ->
529 -- This Anything is useful because some Ctors are missing.
530 -- But what if a previous row has an Anything?
531 -- If so, this one is not useful.
532 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
534 Yes alts ->
535 -- All Ctors are covered, so this Anything is not needed for any
536 -- of those. But what if some of those Ctors have subpatterns
537 -- that make them less general? If so, this actually is useful!
538 let
539 isUsefulAlt (Can.Ctor name _ arity _) =
540 isUseful
541 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
542 (replicate arity Anything ++ patterns)
543 in
544 any isUsefulAlt alts
546 Literal literal ->
547 -- keep checking rows that start with this Literal or Anything
548 isUseful
549 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
550 patterns
553-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
554specializeRowByCtor :: Name.Name -> Int -> [Pattern] -> Maybe [Pattern]
555specializeRowByCtor ctorName arity row =
556 case row of
557 Ctor _ name args : patterns ->
558 if name == ctorName then
559 Just (args ++ patterns)
560 else
561 Nothing
563 Anything : patterns ->
564 Just (replicate arity Anything ++ patterns)
566 Literal _ : _ ->
567 error $
568 "Compiler bug! After type checking, constructors and literals\
569 \ should never align in pattern match exhaustiveness checks."
571 [] ->
572 error "Compiler error! Empty matrices should not get specialized."
575-- INVARIANT: (length row == N) ==> (length result == N-1)
576specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
577specializeRowByLiteral literal row =
578 case row of
579 Literal lit : patterns ->
580 if lit == literal then
581 Just patterns
582 else
583 Nothing
585 Anything : patterns ->
586 Just patterns
588 Ctor _ _ _ : _ ->
589 error $
590 "Compiler bug! After type checking, constructors and literals\
591 \ should never align in pattern match exhaustiveness checks."
593 [] ->
594 error "Compiler error! Empty matrices should not get specialized."
597-- INVARIANT: (length row == N) ==> (length result == N-1)
598specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
599specializeRowByAnything row =
600 case row of
601 [] ->
602 Nothing
604 Ctor _ _ _ : _ ->
605 Nothing
607 Anything : patterns ->
608 Just patterns
610 Literal _ : _ ->
611 Nothing
615-- ALL CONSTRUCTORS ARE PRESENT?
618data Complete
619 = Yes [Can.Ctor]
620 | No
623isComplete :: [[Pattern]] -> Complete
624isComplete matrix =
625 let
626 ctors = collectCtors matrix
627 numSeen = Map.size ctors
628 in
629 if numSeen == 0 then
630 No
631 else
632 let (Can.Union _ alts numAlts _) = snd (Map.findMin ctors) in
633 if numSeen == numAlts then Yes alts else No
637-- COLLECT CTORS
640collectCtors :: [[Pattern]] -> Map.Map Name.Name Can.Union
641collectCtors matrix =
642 List.foldl' collectCtorsHelp Map.empty matrix
645collectCtorsHelp :: Map.Map Name.Name Can.Union -> [Pattern] -> Map.Map Name.Name Can.Union
646collectCtorsHelp ctors row =
647 case row of
648 Ctor union name _ : _ ->
649 Map.insert name union ctors
651 _ ->
652 ctors