git.iko.soy/elk
on 2edbe13 help sign in
elk/compiler/src/Nitpick/PatternMatches.hs
653 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.NonEmptyList as NE
26import qualified AST.Canonical as Can
27import qualified Data.Index as Index
28import qualified Elm.ModuleName as ModuleName
29import qualified Elm.String as ES
30import qualified Reporting.Annotation as A
34-- PATTERN
37data Pattern
38 = Anything
39 | Literal Literal
40 | Ctor Can.Union Name.Name [Pattern]
43data Literal
44 = Chr ES.String
45 | Str ES.String
46 | Int Int
47 deriving (Eq)
51-- CREATE SIMPLIFIED PATTERNS
54simplify :: Can.Pattern -> Pattern
55simplify (A.At _ pattern) =
56 case pattern of
57 Can.PAnything ->
58 Anything
60 Can.PVar _ ->
61 Anything
63 Can.PRecord _ ->
64 Anything
66 Can.PUnit ->
67 Ctor unit unitName []
69 Can.PTuple a b Nothing ->
70 Ctor pair pairName [ simplify a, simplify b ]
72 Can.PTuple a b (Just c) ->
73 Ctor triple tripleName [ simplify a, simplify b, simplify c ]
75 Can.PCtor _ _ union name _ args ->
76 Ctor union name $
77 map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args
79 Can.PList entries ->
80 foldr cons nil entries
82 Can.PCons hd tl ->
83 cons hd (simplify tl)
85 Can.PAlias subPattern _ ->
86 simplify subPattern
88 Can.PInt int ->
89 Literal (Int int)
91 Can.PStr str ->
92 Literal (Str str)
94 Can.PChr chr ->
95 Literal (Chr chr)
97 Can.PBool union bool ->
98 Ctor union (if bool then Name.true else Name.false) []
101cons :: Can.Pattern -> Pattern -> Pattern
102cons hd tl =
103 Ctor list consName [ simplify hd, tl ]
106{-# NOINLINE nil #-}
107nil :: Pattern
108nil =
109 Ctor list nilName []
113-- BUILT-IN UNIONS
116{-# NOINLINE unit #-}
117unit :: Can.Union
118unit =
119 let
120 ctor =
121 Can.Ctor unitName Index.first 0 []
122 in
123 Can.Union [] [ ctor ] 1 Can.Normal
126{-# NOINLINE pair #-}
127pair :: Can.Union
128pair =
129 let
130 ctor =
131 Can.Ctor pairName Index.first 2 [Can.TVar "a", Can.TVar "b"]
132 in
133 Can.Union ["a","b"] [ ctor ] 1 Can.Normal
136{-# NOINLINE triple #-}
137triple :: Can.Union
138triple =
139 let
140 ctor =
141 Can.Ctor tripleName Index.first 3 [Can.TVar "a", Can.TVar "b", Can.TVar "c"]
142 in
143 Can.Union ["a","b","c"] [ ctor ] 1 Can.Normal
146{-# NOINLINE list #-}
147list :: Can.Union
148list =
149 let
150 nilCtor =
151 Can.Ctor nilName Index.first 0 []
153 consCtor =
154 Can.Ctor consName Index.second 2
155 [ Can.TVar "a"
156 , Can.TType ModuleName.list Name.list [Can.TVar "a"]
157 ]
158 in
159 Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal
162{-# NOINLINE unitName #-}
163unitName :: Name.Name
164unitName = "#0"
167{-# NOINLINE pairName #-}
168pairName :: Name.Name
169pairName = "#2"
172{-# NOINLINE tripleName #-}
173tripleName :: Name.Name
174tripleName = "#3"
177{-# NOINLINE consName #-}
178consName :: Name.Name
179consName = "::"
182{-# NOINLINE nilName #-}
183nilName :: Name.Name
184nilName = "[]"
188-- ERROR
191data Error
192 = Incomplete A.Region Context [Pattern]
193 | Redundant A.Region A.Region Int
196data Context
197 = BadArg
198 | BadDestruct
199 | BadCase
203-- CHECK
206check :: Can.Module -> Either (NE.List Error) ()
207check (Can.Module _ _ _ decls _ _ _ _) =
208 case checkDecls decls [] of
209 [] ->
210 Right ()
212 e:es ->
213 Left (NE.List e es)
217-- CHECK DECLS
220checkDecls :: Can.Decls -> [Error] -> [Error]
221checkDecls decls errors =
222 case decls of
223 Can.Declare def subDecls ->
224 checkDef def $ checkDecls subDecls errors
226 Can.DeclareRec def defs subDecls ->
227 checkDef def (foldr checkDef (checkDecls subDecls errors) defs)
229 Can.SaveTheEnvironment ->
230 errors
234-- CHECK DEFS
237checkDef :: Can.Def -> [Error] -> [Error]
238checkDef def errors =
239 case def of
240 Can.Def _ args body ->
241 foldr checkArg (checkExpr body errors) args
243 Can.TypedDef _ _ args body _ ->
244 foldr checkTypedArg (checkExpr body errors) args
247checkArg :: Can.Pattern -> [Error] -> [Error]
248checkArg pattern@(A.At region _) errors =
249 checkPatterns region BadArg [pattern] errors
252checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
253checkTypedArg (pattern@(A.At region _), _) errors =
254 checkPatterns region BadArg [pattern] errors
258-- CHECK EXPRESSIONS
261checkExpr :: Can.Expr -> [Error] -> [Error]
262checkExpr (A.At region expression) errors =
263 case expression of
264 Can.VarLocal _ ->
265 errors
267 Can.VarTopLevel _ _ ->
268 errors
270 Can.VarKernel _ _ ->
271 errors
273 Can.VarForeign _ _ _ ->
274 errors
276 Can.VarCtor _ _ _ _ _ ->
277 errors
279 Can.VarDebug _ _ _ ->
280 errors
282 Can.VarOperator _ _ _ _ ->
283 errors
285 Can.Chr _ ->
286 errors
288 Can.Str _ ->
289 errors
291 Can.Int _ ->
292 errors
294 Can.Float _ ->
295 errors
297 Can.List entries ->
298 foldr checkExpr errors entries
300 Can.Negate expr ->
301 checkExpr expr errors
303 Can.Binop _ _ _ _ left right ->
304 checkExpr left $
305 checkExpr right errors
307 Can.Lambda args body ->
308 foldr checkArg (checkExpr body errors) args
310 Can.Call func args ->
311 checkExpr func $ foldr checkExpr errors args
313 Can.If branches finally ->
314 foldr checkIfBranch (checkExpr finally errors) branches
316 Can.Let def body ->
317 checkDef def $ checkExpr body errors
319 Can.LetRec defs body ->
320 foldr checkDef (checkExpr body errors) defs
322 Can.LetDestruct pattern@(A.At reg _) expr body ->
323 checkPatterns reg BadDestruct [pattern] $
324 checkExpr expr $ checkExpr body errors
326 Can.Case expr branches ->
327 checkExpr expr $ checkCases region branches errors
329 Can.Accessor _ ->
330 errors
332 Can.Access record _ ->
333 checkExpr record errors
335 Can.Update _ record fields ->
336 checkExpr record $ Map.foldr checkField errors fields
338 Can.Record fields ->
339 Map.foldr checkExpr errors fields
341 Can.Unit ->
342 errors
344 Can.Tuple a b maybeC ->
345 checkExpr a $
346 checkExpr b $
347 case maybeC of
348 Nothing ->
349 errors
351 Just c ->
352 checkExpr c errors
354 Can.Shader _ _ ->
355 errors
359-- CHECK FIELD
362checkField :: Can.FieldUpdate -> [Error] -> [Error]
363checkField (Can.FieldUpdate _ expr) errors =
364 checkExpr expr errors
368-- CHECK IF BRANCH
371checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
372checkIfBranch (condition, branch) errs =
373 checkExpr condition $ checkExpr branch errs
377-- CHECK CASE EXPRESSION
380checkCases :: A.Region -> [Can.CaseBranch] -> [Error] -> [Error]
381checkCases region branches errors =
382 let
383 (patterns, newErrors) =
384 foldr checkCaseBranch ([], errors) branches
385 in
386 checkPatterns region BadCase patterns newErrors
389checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
390checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
391 ( pattern:patterns
392 , checkExpr expr errors
393 )
397-- CHECK PATTERNS
400checkPatterns :: A.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
401checkPatterns region context patterns errors =
402 case toNonRedundantRows region patterns of
403 Left err ->
404 err:errors
406 Right matrix ->
407 case isExhaustive matrix 1 of
408 [] ->
409 errors
411 badPatterns ->
412 Incomplete region context (map head badPatterns) : errors
416-- EXHAUSTIVE PATTERNS
419-- INVARIANTS:
420--
421-- The initial rows "matrix" are all of length 1
422-- The initial count of items per row "n" is also 1
423-- The resulting rows are examples of missing patterns
424--
425isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
426isExhaustive matrix n =
427 case matrix of
428 [] ->
429 [replicate n Anything]
431 _ ->
432 if n == 0 then
433 []
434 else
435 let
436 ctors = collectCtors matrix
437 numSeen = Map.size ctors
438 in
439 if numSeen == 0 then
440 (:) Anything
441 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
443 else
444 let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in
445 if numSeen < numAlts then
446 (:)
447 <$> Maybe.mapMaybe (isMissing alts ctors) altList
448 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
450 else
451 let
452 isAltExhaustive (Can.Ctor name _ arity _) =
453 recoverCtor alts name arity <$>
454 isExhaustive
455 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
456 (arity + n - 1)
457 in
458 concatMap isAltExhaustive altList
461isMissing :: Can.Union -> Map.Map Name.Name a -> Can.Ctor -> Maybe Pattern
462isMissing union ctors (Can.Ctor name _ arity _) =
463 if Map.member name ctors then
464 Nothing
465 else
466 Just (Ctor union name (replicate arity Anything))
469recoverCtor :: Can.Union -> Name.Name -> Int -> [Pattern] -> [Pattern]
470recoverCtor union name arity patterns =
471 let
472 (args, rest) =
473 splitAt arity patterns
474 in
475 Ctor union name args : rest
479-- REDUNDANT PATTERNS
482-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
483toNonRedundantRows :: A.Region -> [Can.Pattern] -> Either Error [[Pattern]]
484toNonRedundantRows region patterns =
485 toSimplifiedUsefulRows region [] patterns
488-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
489toSimplifiedUsefulRows :: A.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
490toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
491 case uncheckedPatterns of
492 [] ->
493 Right checkedRows
495 pattern@(A.At region _) : rest ->
496 let nextRow = [simplify pattern] in
497 if isUseful checkedRows nextRow then
498 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
499 else
500 Left (Redundant overallRegion region (length checkedRows + 1))
503-- Check if a new row "vector" is useful given previous rows "matrix"
504isUseful :: [[Pattern]] -> [Pattern] -> Bool
505isUseful matrix vector =
506 case matrix of
507 [] ->
508 -- No rows are the same as the new vector! The vector is useful!
509 True
511 _ ->
512 case vector of
513 [] ->
514 -- There is nothing left in the new vector, but we still have
515 -- rows that match the same things. This is not a useful vector!
516 False
518 firstPattern : patterns ->
519 case firstPattern of
520 Ctor _ name args ->
521 -- keep checking rows that start with this Ctor or Anything
522 isUseful
523 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
524 (args ++ patterns)
526 Anything ->
527 -- check if all alts appear in matrix
528 case isComplete matrix of
529 No ->
530 -- This Anything is useful because some Ctors are missing.
531 -- But what if a previous row has an Anything?
532 -- If so, this one is not useful.
533 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
535 Yes alts ->
536 -- All Ctors are covered, so this Anything is not needed for any
537 -- of those. But what if some of those Ctors have subpatterns
538 -- that make them less general? If so, this actually is useful!
539 let
540 isUsefulAlt (Can.Ctor name _ arity _) =
541 isUseful
542 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
543 (replicate arity Anything ++ patterns)
544 in
545 any isUsefulAlt alts
547 Literal literal ->
548 -- keep checking rows that start with this Literal or Anything
549 isUseful
550 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
551 patterns
554-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
555specializeRowByCtor :: Name.Name -> Int -> [Pattern] -> Maybe [Pattern]
556specializeRowByCtor ctorName arity row =
557 case row of
558 Ctor _ name args : patterns ->
559 if name == ctorName then
560 Just (args ++ patterns)
561 else
562 Nothing
564 Anything : patterns ->
565 Just (replicate arity Anything ++ patterns)
567 Literal _ : _ ->
568 error $
569 "Compiler bug! After type checking, constructors and literals\
570 \ should never align in pattern match exhaustiveness checks."
572 [] ->
573 error "Compiler error! Empty matrices should not get specialized."
576-- INVARIANT: (length row == N) ==> (length result == N-1)
577specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
578specializeRowByLiteral literal row =
579 case row of
580 Literal lit : patterns ->
581 if lit == literal then
582 Just patterns
583 else
584 Nothing
586 Anything : patterns ->
587 Just patterns
589 Ctor _ _ _ : _ ->
590 error $
591 "Compiler bug! After type checking, constructors and literals\
592 \ should never align in pattern match exhaustiveness checks."
594 [] ->
595 error "Compiler error! Empty matrices should not get specialized."
598-- INVARIANT: (length row == N) ==> (length result == N-1)
599specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
600specializeRowByAnything row =
601 case row of
602 [] ->
603 Nothing
605 Ctor _ _ _ : _ ->
606 Nothing
608 Anything : patterns ->
609 Just patterns
611 Literal _ : _ ->
612 Nothing
616-- ALL CONSTRUCTORS ARE PRESENT?
619data Complete
620 = Yes [Can.Ctor]
621 | No
624isComplete :: [[Pattern]] -> Complete
625isComplete matrix =
626 let
627 ctors = collectCtors matrix
628 numSeen = Map.size ctors
629 in
630 if numSeen == 0 then
631 No
632 else
633 let (Can.Union _ alts numAlts _) = snd (Map.findMin ctors) in
634 if numSeen == numAlts then Yes alts else No
638-- COLLECT CTORS
641collectCtors :: [[Pattern]] -> Map.Map Name.Name Can.Union
642collectCtors matrix =
643 List.foldl' collectCtorsHelp Map.empty matrix
646collectCtorsHelp :: Map.Map Name.Name Can.Union -> [Pattern] -> Map.Map Name.Name Can.Union
647collectCtorsHelp ctors row =
648 case row of
649 Ctor union name _ : _ ->
650 Map.insert name union ctors
652 _ ->
653 ctors