git.iko.soy/elk
on 7dfbc30 help sign in
elk/src/Nitpick/PatternMatches.hs
615 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 Elm.Name as N
27import qualified Reporting.Annotation as A
28import qualified Reporting.Region as R
32-- PATTERN
35data Pattern
36 = Anything
37 | Literal Literal
38 | Ctor Can.CtorAlts N.Name [Pattern]
39 deriving (Eq)
42data Literal
43 = Chr Text.Text
44 | Str Text.Text
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 unitAlts unitName []
68 Can.PTuple a b Nothing ->
69 Ctor pairAlts pairName [ simplify a, simplify b ]
71 Can.PTuple a b (Just c) ->
72 Ctor tripleAlts tripleName [ simplify a, simplify b, simplify c ]
74 Can.PCtor _ _ _ alts name _ args ->
75 Ctor alts 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)
97cons :: Can.Pattern -> Pattern -> Pattern
98cons hd tl =
99 Ctor listAlts consName [ simplify hd, tl ]
102{-# NOINLINE nil #-}
103nil :: Pattern
104nil =
105 Ctor listAlts nilName []
109-- ALTS
112{-# NOINLINE unitAlts #-}
113unitAlts :: Can.CtorAlts
114unitAlts =
115 Can.toAlts [ Can.CtorAlt unitName 0 ]
118{-# NOINLINE pairAlts #-}
119pairAlts :: Can.CtorAlts
120pairAlts =
121 Can.toAlts [ Can.CtorAlt pairName 2 ]
124{-# NOINLINE tripleAlts #-}
125tripleAlts :: Can.CtorAlts
126tripleAlts =
127 Can.toAlts [ Can.CtorAlt tripleName 3 ]
130{-# NOINLINE listAlts #-}
131listAlts :: Can.CtorAlts
132listAlts =
133 Can.toAlts [ Can.CtorAlt consName 2, Can.CtorAlt nilName 0 ]
136{-# NOINLINE unitName #-}
137unitName :: N.Name
138unitName = "#0"
141{-# NOINLINE pairName #-}
142pairName :: N.Name
143pairName = "#2"
146{-# NOINLINE tripleName #-}
147tripleName :: N.Name
148tripleName = "#3"
151{-# NOINLINE consName #-}
152consName :: N.Name
153consName = "::"
156{-# NOINLINE nilName #-}
157nilName :: N.Name
158nilName = "[]"
162-- ERROR
165data Error
166 = Incomplete R.Region Context [Pattern]
167 | Redundant R.Region R.Region Int
170data Context
171 = BadArg
172 | BadDestruct
173 | BadCase
177-- CHECK
180check :: Can.Module -> Either [Error] ()
181check (Can.Module _ _ _ decls _ _ _ _) =
182 case checkDecls decls [] of
183 [] ->
184 Right ()
186 errors ->
187 Left errors
191-- CHECK DECLS
194checkDecls :: Can.Decls -> [Error] -> [Error]
195checkDecls decls errors =
196 case decls of
197 Can.Declare def subDecls ->
198 checkDef def $ checkDecls subDecls errors
200 Can.DeclareRec defs subDecls ->
201 foldr checkDef (checkDecls subDecls errors) defs
203 Can.SaveTheEnvironment ->
204 errors
208-- CHECK DEFS
211checkDef :: Can.Def -> [Error] -> [Error]
212checkDef def errors =
213 case def of
214 Can.Def _ args body ->
215 foldr checkArg (checkExpr body errors) args
217 Can.TypedDef _ _ args body _ ->
218 foldr checkTypedArg (checkExpr body errors) args
221checkArg :: Can.Pattern -> [Error] -> [Error]
222checkArg pattern@(A.At region _) errors =
223 checkPatterns region BadArg [pattern] errors
226checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
227checkTypedArg (pattern@(A.At region _), _) errors =
228 checkPatterns region BadArg [pattern] errors
232-- CHECK EXPRESSIONS
235checkExpr :: Can.Expr -> [Error] -> [Error]
236checkExpr (A.At region expression) errors =
237 case expression of
238 Can.VarLocal _ ->
239 errors
241 Can.VarTopLevel _ _ ->
242 errors
244 Can.VarKernel _ _ ->
245 errors
247 Can.VarForeign _ _ _ ->
248 errors
250 Can.VarDebug _ _ _ ->
251 errors
253 Can.VarOperator _ _ _ _ ->
254 errors
256 Can.Chr _ ->
257 errors
259 Can.Str _ ->
260 errors
262 Can.Int _ ->
263 errors
265 Can.Float _ ->
266 errors
268 Can.List entries ->
269 foldr checkExpr errors entries
271 Can.Negate expr ->
272 checkExpr expr errors
274 Can.Binop _ _ _ _ left right ->
275 checkExpr left $
276 checkExpr right errors
278 Can.Lambda args body ->
279 foldr checkArg (checkExpr body errors) args
281 Can.Call func args ->
282 checkExpr func $ foldr checkExpr errors args
284 Can.If branches finally ->
285 foldr checkIfBranch (checkExpr finally errors) branches
287 Can.Let def body ->
288 checkDef def $ checkExpr body errors
290 Can.LetRec defs body ->
291 foldr checkDef (checkExpr body errors) defs
293 Can.LetDestruct pattern@(A.At reg _) expr body ->
294 checkPatterns reg BadDestruct [pattern] $
295 checkExpr expr $ checkExpr body errors
297 Can.Case expr branches ->
298 checkExpr expr $ checkCases region branches errors
300 Can.Accessor _ ->
301 errors
303 Can.Access record _ ->
304 checkExpr record errors
306 Can.Update record fields ->
307 checkExpr record $ Map.foldr checkExpr errors fields
309 Can.Record fields ->
310 Map.foldr checkExpr errors fields
312 Can.Unit ->
313 errors
315 Can.Tuple a b maybeC ->
316 checkExpr a $
317 checkExpr b $
318 case maybeC of
319 Nothing ->
320 errors
322 Just c ->
323 checkExpr c errors
325 Can.Shader _ _ _ ->
326 errors
330-- CHECK IF BRANCH
333checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
334checkIfBranch (condition, branch) errs =
335 checkExpr condition $ checkExpr branch errs
339-- CHECK CASE EXPRESSION
342checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
343checkCases region branches errors =
344 let
345 (patterns, newErrors) =
346 foldr checkCaseBranch ([], errors) branches
347 in
348 checkPatterns region BadCase patterns newErrors
351checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
352checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
353 ( pattern:patterns
354 , checkExpr expr errors
355 )
359-- CHECK PATTERNS
362checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
363checkPatterns region context patterns errors =
364 case toNonRedundantRows region patterns of
365 Left err ->
366 err:errors
368 Right matrix ->
369 case isExhaustive matrix 1 of
370 [] ->
371 errors
373 badPatterns ->
374 Incomplete region context (map head badPatterns) : errors
378-- EXHAUSTIVE PATTERNS
381-- INVARIANTS:
382--
383-- The initial rows "matrix" are all of length 1
384-- The initial count of items per row "n" is also 1
385-- The resulting rows are examples of missing patterns
386--
387isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
388isExhaustive matrix n =
389 case matrix of
390 [] ->
391 [replicate n Anything]
393 _ ->
394 if n == 0 then
395 []
396 else
397 let
398 ctors = collectCtors matrix
399 numSeen = Map.size ctors
400 in
401 if numSeen == 0 then
402 (:) Anything
403 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
405 else
406 let alts@(Can.CtorAlts numAlts altList) = snd (Map.findMin ctors) in
407 if numSeen < numAlts then
408 (:)
409 <$> Maybe.mapMaybe (isMissing alts ctors) altList
410 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
412 else
413 let
414 isAltExhaustive (Can.CtorAlt name arity) =
415 recoverCtor alts name arity <$>
416 isExhaustive
417 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
418 (arity + n - 1)
419 in
420 concatMap isAltExhaustive altList
423isMissing :: Can.CtorAlts -> Map.Map N.Name a -> Can.CtorAlt -> Maybe Pattern
424isMissing alts ctors (Can.CtorAlt name arity) =
425 if Map.member name ctors then
426 Nothing
427 else
428 Just (Ctor alts name (replicate arity Anything))
431recoverCtor :: Can.CtorAlts -> N.Name -> Int -> [Pattern] -> [Pattern]
432recoverCtor alts name arity patterns =
433 let
434 (args, rest) =
435 splitAt arity patterns
436 in
437 Ctor alts name args : rest
441-- REDUNDANT PATTERNS
444-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
445toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
446toNonRedundantRows region patterns =
447 toSimplifiedUsefulRows region [] patterns
450-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
451toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
452toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
453 case uncheckedPatterns of
454 [] ->
455 Right checkedRows
457 pattern@(A.At region _) : rest ->
458 let nextRow = [simplify pattern] in
459 if isUseful checkedRows nextRow then
460 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
461 else
462 Left (Redundant overallRegion region (length checkedRows + 1))
465-- Check if a new row "vector" is useful given previous rows "matrix"
466isUseful :: [[Pattern]] -> [Pattern] -> Bool
467isUseful matrix vector =
468 case matrix of
469 [] ->
470 -- No rows are the same as the new vector! The vector is useful!
471 True
473 _ ->
474 case vector of
475 [] ->
476 -- There is nothing left in the new vector, but we still have
477 -- rows that match the same things. This is not a useful vector!
478 False
480 firstPattern : patterns ->
481 case firstPattern of
482 Ctor _ name args ->
483 -- keep checking rows that start with this Ctor or Anything
484 isUseful
485 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
486 (args ++ patterns)
488 Anything ->
489 -- check if all alts appear in matrix
490 case isComplete matrix of
491 No ->
492 -- This Anything is useful because some Ctors are missing.
493 -- But what if a previous row has an Anything?
494 -- If so, this one is not useful.
495 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
497 Yes alts ->
498 -- All Ctors are covered, so this Anything is not needed for any
499 -- of those. But what if some of those Ctors have subpatterns
500 -- that make them less general? If so, this actually is useful!
501 let
502 isUsefulAlt (Can.CtorAlt ctor arity) =
503 isUseful
504 (Maybe.mapMaybe (specializeRowByCtor ctor arity) matrix)
505 (replicate arity Anything ++ patterns)
506 in
507 any isUsefulAlt alts
509 Literal literal ->
510 -- keep checking rows that start with this Literal or Anything
511 isUseful
512 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
513 patterns
516-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
517specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]
518specializeRowByCtor ctorName arity row =
519 case row of
520 Ctor _ name args : patterns ->
521 if name == ctorName then
522 Just (args ++ patterns)
523 else
524 Nothing
526 Anything : patterns ->
527 Just (replicate arity Anything ++ patterns)
529 Literal _ : _ ->
530 error $
531 "Compiler bug! After type checking, constructors and literals\
532 \ should never align in pattern match exhaustiveness checks."
534 [] ->
535 error "Compiler error! Empty matrices should not get specialized."
538-- INVARIANT: (length row == N) ==> (length result == N-1)
539specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
540specializeRowByLiteral literal row =
541 case row of
542 Literal lit : patterns ->
543 if lit == literal then
544 Just patterns
545 else
546 Nothing
548 Anything : patterns ->
549 Just patterns
551 Ctor _ _ _ : _ ->
552 error $
553 "Compiler bug! After type checking, constructors and literals\
554 \ should never align in pattern match exhaustiveness checks."
556 [] ->
557 error "Compiler error! Empty matrices should not get specialized."
560-- INVARIANT: (length row == N) ==> (length result == N-1)
561specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
562specializeRowByAnything row =
563 case row of
564 [] ->
565 Nothing
567 Ctor _ _ _ : _ ->
568 Nothing
570 Anything : patterns ->
571 Just patterns
573 Literal _ : _ ->
574 Nothing
578-- ALL CONSTRUCTORS ARE PRESENT?
581data Complete
582 = Yes [Can.CtorAlt]
583 | No
586isComplete :: [[Pattern]] -> Complete
587isComplete matrix =
588 let
589 ctors = collectCtors matrix
590 numSeen = Map.size ctors
591 in
592 if numSeen == 0 then
593 No
594 else
595 let (Can.CtorAlts numAlts alts) = snd (Map.findMin ctors) in
596 if numSeen == numAlts then Yes alts else No
600-- COLLECT CTORS
603collectCtors :: [[Pattern]] -> Map.Map N.Name Can.CtorAlts
604collectCtors matrix =
605 List.foldl' collectCtorsHelp Map.empty matrix
608collectCtorsHelp :: Map.Map N.Name Can.CtorAlts -> [Pattern] -> Map.Map N.Name Can.CtorAlts
609collectCtorsHelp ctors row =
610 case row of
611 Ctor alts name _ : _ ->
612 Map.insert name alts ctors
614 _ ->
615 ctors