git.iko.soy/elk
on 233cfc8 help sign in
elk/compiler/src/Nitpick/PatternMatches.hs
650 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.Text as Text
25import qualified AST.Canonical as Can
26import qualified AST.Module.Name as ModuleName
27import qualified Data.Index as Index
28import qualified Elm.Name as N
29import qualified Reporting.Annotation as A
30import qualified Reporting.Region as R
34-- PATTERN
37data Pattern
38 = Anything
39 | Literal Literal
40 | Ctor Can.Union N.Name [Pattern]
43data Literal
44 = Chr Text.Text
45 | Str Text.Text
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)
98cons :: Can.Pattern -> Pattern -> Pattern
99cons hd tl =
100 Ctor list consName [ simplify hd, tl ]
103{-# NOINLINE nil #-}
104nil :: Pattern
105nil =
106 Ctor list nilName []
110-- BUILT-IN UNIONS
113{-# NOINLINE unit #-}
114unit :: Can.Union
115unit =
116 let
117 ctor =
118 Can.Ctor unitName Index.first 0 []
119 in
120 Can.Union [] [ ctor ] 1 Can.Normal
123{-# NOINLINE pair #-}
124pair :: Can.Union
125pair =
126 let
127 ctor =
128 Can.Ctor pairName Index.first 2 [Can.TVar "a", Can.TVar "b"]
129 in
130 Can.Union ["a","b"] [ ctor ] 1 Can.Normal
133{-# NOINLINE triple #-}
134triple :: Can.Union
135triple =
136 let
137 ctor =
138 Can.Ctor tripleName Index.first 3 [Can.TVar "a", Can.TVar "b", Can.TVar "c"]
139 in
140 Can.Union ["a","b","c"] [ ctor ] 1 Can.Normal
143{-# NOINLINE list #-}
144list :: Can.Union
145list =
146 let
147 nilCtor =
148 Can.Ctor nilName Index.first 0 []
150 consCtor =
151 Can.Ctor consName Index.second 2
152 [ Can.TVar "a"
153 , Can.TType ModuleName.list N.list [Can.TVar "a"]
154 ]
155 in
156 Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal
159{-# NOINLINE unitName #-}
160unitName :: N.Name
161unitName = "#0"
164{-# NOINLINE pairName #-}
165pairName :: N.Name
166pairName = "#2"
169{-# NOINLINE tripleName #-}
170tripleName :: N.Name
171tripleName = "#3"
174{-# NOINLINE consName #-}
175consName :: N.Name
176consName = "::"
179{-# NOINLINE nilName #-}
180nilName :: N.Name
181nilName = "[]"
185-- ERROR
188data Error
189 = Incomplete R.Region Context [Pattern]
190 | Redundant R.Region R.Region Int
193data Context
194 = BadArg
195 | BadDestruct
196 | BadCase
200-- CHECK
203check :: Can.Module -> Either [Error] ()
204check (Can.Module _ _ _ decls _ _ _ _) =
205 case checkDecls decls [] of
206 [] ->
207 Right ()
209 errors ->
210 Left errors
214-- CHECK DECLS
217checkDecls :: Can.Decls -> [Error] -> [Error]
218checkDecls decls errors =
219 case decls of
220 Can.Declare def subDecls ->
221 checkDef def $ checkDecls subDecls errors
223 Can.DeclareRec defs subDecls ->
224 foldr checkDef (checkDecls subDecls errors) defs
226 Can.SaveTheEnvironment ->
227 errors
231-- CHECK DEFS
234checkDef :: Can.Def -> [Error] -> [Error]
235checkDef def errors =
236 case def of
237 Can.Def _ args body ->
238 foldr checkArg (checkExpr body errors) args
240 Can.TypedDef _ _ args body _ ->
241 foldr checkTypedArg (checkExpr body errors) args
244checkArg :: Can.Pattern -> [Error] -> [Error]
245checkArg pattern@(A.At region _) errors =
246 checkPatterns region BadArg [pattern] errors
249checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
250checkTypedArg (pattern@(A.At region _), _) errors =
251 checkPatterns region BadArg [pattern] errors
255-- CHECK EXPRESSIONS
258checkExpr :: Can.Expr -> [Error] -> [Error]
259checkExpr (A.At region expression) errors =
260 case expression of
261 Can.VarLocal _ ->
262 errors
264 Can.VarTopLevel _ _ ->
265 errors
267 Can.VarKernel _ _ ->
268 errors
270 Can.VarForeign _ _ _ ->
271 errors
273 Can.VarCtor _ _ _ _ _ ->
274 errors
276 Can.VarDebug _ _ _ ->
277 errors
279 Can.VarOperator _ _ _ _ ->
280 errors
282 Can.Chr _ ->
283 errors
285 Can.Str _ ->
286 errors
288 Can.Int _ ->
289 errors
291 Can.Float _ ->
292 errors
294 Can.List entries ->
295 foldr checkExpr errors entries
297 Can.Negate expr ->
298 checkExpr expr errors
300 Can.Binop _ _ _ _ left right ->
301 checkExpr left $
302 checkExpr right errors
304 Can.Lambda args body ->
305 foldr checkArg (checkExpr body errors) args
307 Can.Call func args ->
308 checkExpr func $ foldr checkExpr errors args
310 Can.If branches finally ->
311 foldr checkIfBranch (checkExpr finally errors) branches
313 Can.Let def body ->
314 checkDef def $ checkExpr body errors
316 Can.LetRec defs body ->
317 foldr checkDef (checkExpr body errors) defs
319 Can.LetDestruct pattern@(A.At reg _) expr body ->
320 checkPatterns reg BadDestruct [pattern] $
321 checkExpr expr $ checkExpr body errors
323 Can.Case expr branches ->
324 checkExpr expr $ checkCases region branches errors
326 Can.Accessor _ ->
327 errors
329 Can.Access record _ ->
330 checkExpr record errors
332 Can.Update _ record fields ->
333 checkExpr record $ Map.foldr checkField errors fields
335 Can.Record fields ->
336 Map.foldr checkExpr errors fields
338 Can.Unit ->
339 errors
341 Can.Tuple a b maybeC ->
342 checkExpr a $
343 checkExpr b $
344 case maybeC of
345 Nothing ->
346 errors
348 Just c ->
349 checkExpr c errors
351 Can.Shader _ _ _ ->
352 errors
356-- CHECK FIELD
359checkField :: Can.FieldUpdate -> [Error] -> [Error]
360checkField (Can.FieldUpdate _ expr) errors =
361 checkExpr expr errors
365-- CHECK IF BRANCH
368checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
369checkIfBranch (condition, branch) errs =
370 checkExpr condition $ checkExpr branch errs
374-- CHECK CASE EXPRESSION
377checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
378checkCases region branches errors =
379 let
380 (patterns, newErrors) =
381 foldr checkCaseBranch ([], errors) branches
382 in
383 checkPatterns region BadCase patterns newErrors
386checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
387checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
388 ( pattern:patterns
389 , checkExpr expr errors
390 )
394-- CHECK PATTERNS
397checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
398checkPatterns region context patterns errors =
399 case toNonRedundantRows region patterns of
400 Left err ->
401 err:errors
403 Right matrix ->
404 case isExhaustive matrix 1 of
405 [] ->
406 errors
408 badPatterns ->
409 Incomplete region context (map head badPatterns) : errors
413-- EXHAUSTIVE PATTERNS
416-- INVARIANTS:
417--
418-- The initial rows "matrix" are all of length 1
419-- The initial count of items per row "n" is also 1
420-- The resulting rows are examples of missing patterns
421--
422isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
423isExhaustive matrix n =
424 case matrix of
425 [] ->
426 [replicate n Anything]
428 _ ->
429 if n == 0 then
430 []
431 else
432 let
433 ctors = collectCtors matrix
434 numSeen = Map.size ctors
435 in
436 if numSeen == 0 then
437 (:) Anything
438 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
440 else
441 let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in
442 if numSeen < numAlts then
443 (:)
444 <$> Maybe.mapMaybe (isMissing alts ctors) altList
445 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
447 else
448 let
449 isAltExhaustive (Can.Ctor name _ arity _) =
450 recoverCtor alts name arity <$>
451 isExhaustive
452 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
453 (arity + n - 1)
454 in
455 concatMap isAltExhaustive altList
458isMissing :: Can.Union -> Map.Map N.Name a -> Can.Ctor -> Maybe Pattern
459isMissing union ctors (Can.Ctor name _ arity _) =
460 if Map.member name ctors then
461 Nothing
462 else
463 Just (Ctor union name (replicate arity Anything))
466recoverCtor :: Can.Union -> N.Name -> Int -> [Pattern] -> [Pattern]
467recoverCtor union name arity patterns =
468 let
469 (args, rest) =
470 splitAt arity patterns
471 in
472 Ctor union name args : rest
476-- REDUNDANT PATTERNS
479-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
480toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
481toNonRedundantRows region patterns =
482 toSimplifiedUsefulRows region [] patterns
485-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
486toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
487toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
488 case uncheckedPatterns of
489 [] ->
490 Right checkedRows
492 pattern@(A.At region _) : rest ->
493 let nextRow = [simplify pattern] in
494 if isUseful checkedRows nextRow then
495 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
496 else
497 Left (Redundant overallRegion region (length checkedRows + 1))
500-- Check if a new row "vector" is useful given previous rows "matrix"
501isUseful :: [[Pattern]] -> [Pattern] -> Bool
502isUseful matrix vector =
503 case matrix of
504 [] ->
505 -- No rows are the same as the new vector! The vector is useful!
506 True
508 _ ->
509 case vector of
510 [] ->
511 -- There is nothing left in the new vector, but we still have
512 -- rows that match the same things. This is not a useful vector!
513 False
515 firstPattern : patterns ->
516 case firstPattern of
517 Ctor _ name args ->
518 -- keep checking rows that start with this Ctor or Anything
519 isUseful
520 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
521 (args ++ patterns)
523 Anything ->
524 -- check if all alts appear in matrix
525 case isComplete matrix of
526 No ->
527 -- This Anything is useful because some Ctors are missing.
528 -- But what if a previous row has an Anything?
529 -- If so, this one is not useful.
530 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
532 Yes alts ->
533 -- All Ctors are covered, so this Anything is not needed for any
534 -- of those. But what if some of those Ctors have subpatterns
535 -- that make them less general? If so, this actually is useful!
536 let
537 isUsefulAlt (Can.Ctor name _ arity _) =
538 isUseful
539 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
540 (replicate arity Anything ++ patterns)
541 in
542 any isUsefulAlt alts
544 Literal literal ->
545 -- keep checking rows that start with this Literal or Anything
546 isUseful
547 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
548 patterns
551-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
552specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]
553specializeRowByCtor ctorName arity row =
554 case row of
555 Ctor _ name args : patterns ->
556 if name == ctorName then
557 Just (args ++ patterns)
558 else
559 Nothing
561 Anything : patterns ->
562 Just (replicate arity Anything ++ patterns)
564 Literal _ : _ ->
565 error $
566 "Compiler bug! After type checking, constructors and literals\
567 \ should never align in pattern match exhaustiveness checks."
569 [] ->
570 error "Compiler error! Empty matrices should not get specialized."
573-- INVARIANT: (length row == N) ==> (length result == N-1)
574specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
575specializeRowByLiteral literal row =
576 case row of
577 Literal lit : patterns ->
578 if lit == literal then
579 Just patterns
580 else
581 Nothing
583 Anything : patterns ->
584 Just patterns
586 Ctor _ _ _ : _ ->
587 error $
588 "Compiler bug! After type checking, constructors and literals\
589 \ should never align in pattern match exhaustiveness checks."
591 [] ->
592 error "Compiler error! Empty matrices should not get specialized."
595-- INVARIANT: (length row == N) ==> (length result == N-1)
596specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
597specializeRowByAnything row =
598 case row of
599 [] ->
600 Nothing
602 Ctor _ _ _ : _ ->
603 Nothing
605 Anything : patterns ->
606 Just patterns
608 Literal _ : _ ->
609 Nothing
613-- ALL CONSTRUCTORS ARE PRESENT?
616data Complete
617 = Yes [Can.Ctor]
618 | No
621isComplete :: [[Pattern]] -> Complete
622isComplete matrix =
623 let
624 ctors = collectCtors matrix
625 numSeen = Map.size ctors
626 in
627 if numSeen == 0 then
628 No
629 else
630 let (Can.Union _ alts numAlts _) = snd (Map.findMin ctors) in
631 if numSeen == numAlts then Yes alts else No
635-- COLLECT CTORS
638collectCtors :: [[Pattern]] -> Map.Map N.Name Can.Union
639collectCtors matrix =
640 List.foldl' collectCtorsHelp Map.empty matrix
643collectCtorsHelp :: Map.Map N.Name Can.Union -> [Pattern] -> Map.Map N.Name Can.Union
644collectCtorsHelp ctors row =
645 case row of
646 Ctor union name _ : _ ->
647 Map.insert name union ctors
649 _ ->
650 ctors