git.iko.soy/elk
on ee5f359 help sign in
elk/src/Nitpick/PatternMatches.hs
614 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Nitpick.PatternMatches
4 ( check
5 , Error(..)
6 , Context(..)
7 , Pattern(..)
8 )
9 where
12{- The algorithm used here comes from "Warnings for Pattern Matching"
13by Luc Maranget. Check it out for more information!
15http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
17-}
19import qualified Data.List as List
20import qualified Data.Map as Map
21import qualified Data.Maybe as Maybe
22import qualified Data.Text as Text
24import qualified AST.Canonical as Can
25import qualified Elm.Name as N
26import qualified Reporting.Annotation as A
27import qualified Reporting.Region as R
31-- PATTERN
34data Pattern
35 = Anything
36 | Literal Literal
37 | Ctor Can.CtorAlts N.Name [Pattern]
38 deriving (Eq)
41data Literal
42 = Chr Text.Text
43 | Str Text.Text
44 | Int Int
45 deriving (Eq)
49-- CREATE SIMPLIFIED PATTERNS
52simplify :: Can.Pattern -> Pattern
53simplify (A.At _ pattern) =
54 case pattern of
55 Can.PAnything ->
56 Anything
58 Can.PVar _ ->
59 Anything
61 Can.PRecord _ ->
62 Anything
64 Can.PUnit ->
65 Ctor unitAlts unitName []
67 Can.PTuple a b Nothing ->
68 Ctor pairAlts pairName [ simplify a, simplify b ]
70 Can.PTuple a b (Just c) ->
71 Ctor tripleAlts tripleName [ simplify a, simplify b, simplify c ]
73 Can.PCtor _ _ _ alts name _ args ->
74 Ctor alts name $
75 map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args
77 Can.PList entries ->
78 foldr cons nil entries
80 Can.PCons hd tl ->
81 cons hd (simplify tl)
83 Can.PAlias subPattern _ ->
84 simplify subPattern
86 Can.PInt int ->
87 Literal (Int int)
89 Can.PStr str ->
90 Literal (Str str)
92 Can.PChr chr ->
93 Literal (Chr chr)
96cons :: Can.Pattern -> Pattern -> Pattern
97cons hd tl =
98 Ctor listAlts consName [ simplify hd, tl ]
101{-# NOINLINE nil #-}
102nil :: Pattern
103nil =
104 Ctor listAlts nilName []
108-- ALTS
111{-# NOINLINE unitAlts #-}
112unitAlts :: Can.CtorAlts
113unitAlts =
114 Can.toAlts [ Can.CtorAlt unitName 0 ]
117{-# NOINLINE pairAlts #-}
118pairAlts :: Can.CtorAlts
119pairAlts =
120 Can.toAlts [ Can.CtorAlt pairName 2 ]
123{-# NOINLINE tripleAlts #-}
124tripleAlts :: Can.CtorAlts
125tripleAlts =
126 Can.toAlts [ Can.CtorAlt tripleName 3 ]
129{-# NOINLINE listAlts #-}
130listAlts :: Can.CtorAlts
131listAlts =
132 Can.toAlts [ Can.CtorAlt consName 2, Can.CtorAlt nilName 0 ]
135{-# NOINLINE unitName #-}
136unitName :: N.Name
137unitName = "#0"
140{-# NOINLINE pairName #-}
141pairName :: N.Name
142pairName = "#2"
145{-# NOINLINE tripleName #-}
146tripleName :: N.Name
147tripleName = "#3"
150{-# NOINLINE consName #-}
151consName :: N.Name
152consName = "::"
155{-# NOINLINE nilName #-}
156nilName :: N.Name
157nilName = "[]"
161-- ERROR
164data Error
165 = Incomplete R.Region Context [Pattern]
166 | Redundant R.Region R.Region Int
169data Context
170 = BadArg
171 | BadDestruct
172 | BadCase
176-- CHECK
179check :: Can.Module -> Either [Error] ()
180check (Can.Module _ _ _ decls _ _ _ _) =
181 case checkDecls decls [] of
182 [] ->
183 Right ()
185 errors ->
186 Left errors
190-- CHECK DECLS
193checkDecls :: Can.Decls -> [Error] -> [Error]
194checkDecls decls errors =
195 case decls of
196 Can.Declare def subDecls ->
197 checkDef def $ checkDecls subDecls errors
199 Can.DeclareRec defs subDecls ->
200 foldr checkDef (checkDecls subDecls errors) defs
202 Can.SaveTheEnvironment ->
203 errors
207-- CHECK DEFS
210checkDef :: Can.Def -> [Error] -> [Error]
211checkDef def errors =
212 case def of
213 Can.Def _ args body ->
214 foldr checkArg (checkExpr body errors) args
216 Can.TypedDef _ _ args body _ ->
217 foldr checkTypedArg (checkExpr body errors) args
220checkArg :: Can.Pattern -> [Error] -> [Error]
221checkArg pattern@(A.At region _) errors =
222 checkPatterns region BadArg [pattern] errors
225checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
226checkTypedArg (pattern@(A.At region _), _) errors =
227 checkPatterns region BadArg [pattern] errors
231-- CHECK EXPRESSIONS
234checkExpr :: Can.Expr -> [Error] -> [Error]
235checkExpr (A.At region expression) errors =
236 case expression of
237 Can.VarLocal _ ->
238 errors
240 Can.VarTopLevel _ _ ->
241 errors
243 Can.VarKernel _ _ ->
244 errors
246 Can.VarForeign _ _ _ ->
247 errors
249 Can.VarDebug _ _ _ ->
250 errors
252 Can.VarOperator _ _ _ _ ->
253 errors
255 Can.Chr _ ->
256 errors
258 Can.Str _ ->
259 errors
261 Can.Int _ ->
262 errors
264 Can.Float _ ->
265 errors
267 Can.List entries ->
268 foldr checkExpr errors entries
270 Can.Negate expr ->
271 checkExpr expr errors
273 Can.Binop _ _ _ _ left right ->
274 checkExpr left $
275 checkExpr right errors
277 Can.Lambda args body ->
278 foldr checkArg (checkExpr body errors) args
280 Can.Call func args ->
281 checkExpr func $ foldr checkExpr errors args
283 Can.If branches finally ->
284 foldr checkIfBranch (checkExpr finally errors) branches
286 Can.Let def body ->
287 checkDef def $ checkExpr body errors
289 Can.LetRec defs body ->
290 foldr checkDef (checkExpr body errors) defs
292 Can.LetDestruct pattern@(A.At reg _) expr body ->
293 checkPatterns reg BadDestruct [pattern] $
294 checkExpr expr $ checkExpr body errors
296 Can.Case expr branches ->
297 checkExpr expr $ checkCases region branches errors
299 Can.Accessor _ ->
300 errors
302 Can.Access record _ ->
303 checkExpr record errors
305 Can.Update record fields ->
306 checkExpr record $ Map.foldr checkExpr errors fields
308 Can.Record fields ->
309 Map.foldr checkExpr errors fields
311 Can.Unit ->
312 errors
314 Can.Tuple a b maybeC ->
315 checkExpr a $
316 checkExpr b $
317 case maybeC of
318 Nothing ->
319 errors
321 Just c ->
322 checkExpr c errors
324 Can.Shader _ _ _ ->
325 errors
329-- CHECK IF BRANCH
332checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
333checkIfBranch (condition, branch) errs =
334 checkExpr condition $ checkExpr branch errs
338-- CHECK CASE EXPRESSION
341checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
342checkCases region branches errors =
343 let
344 (patterns, newErrors) =
345 foldr checkCaseBranch ([], errors) branches
346 in
347 checkPatterns region BadCase patterns newErrors
350checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
351checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
352 ( pattern:patterns
353 , checkExpr expr errors
354 )
358-- CHECK PATTERNS
361checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
362checkPatterns region context patterns errors =
363 case toNonRedundantRows region patterns of
364 Left err ->
365 err:errors
367 Right matrix ->
368 case isExhaustive matrix 1 of
369 [] ->
370 errors
372 badPatterns ->
373 Incomplete region context (map head badPatterns) : errors
377-- EXHAUSTIVE PATTERNS
380-- INVARIANTS:
381--
382-- The initial rows "matrix" are all of length 1
383-- The initial count of items per row "n" is also 1
384-- The resulting rows are examples of missing patterns
385--
386isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
387isExhaustive matrix n =
388 case matrix of
389 [] ->
390 [replicate n Anything]
392 _ ->
393 if n == 0 then
394 []
395 else
396 let
397 ctors = collectCtors matrix
398 numSeen = Map.size ctors
399 in
400 if numSeen == 0 then
401 (:) Anything
402 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
404 else
405 let alts@(Can.CtorAlts numAlts altList) = snd (Map.findMin ctors) in
406 if numSeen < numAlts then
407 (:)
408 <$> Maybe.mapMaybe (isMissing alts ctors) altList
409 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
411 else
412 let
413 isAltExhaustive (Can.CtorAlt name arity) =
414 recoverCtor alts name arity <$>
415 isExhaustive
416 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
417 (arity + n - 1)
418 in
419 concatMap isAltExhaustive altList
422isMissing :: Can.CtorAlts -> Map.Map N.Name a -> Can.CtorAlt -> Maybe Pattern
423isMissing alts ctors (Can.CtorAlt name arity) =
424 if Map.member name ctors then
425 Nothing
426 else
427 Just (Ctor alts name (replicate arity Anything))
430recoverCtor :: Can.CtorAlts -> N.Name -> Int -> [Pattern] -> [Pattern]
431recoverCtor alts name arity patterns =
432 let
433 (args, rest) =
434 splitAt arity patterns
435 in
436 Ctor alts name args : rest
440-- REDUNDANT PATTERNS
443-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
444toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
445toNonRedundantRows region patterns =
446 toSimplifiedUsefulRows region [] patterns
449-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
450toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
451toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
452 case uncheckedPatterns of
453 [] ->
454 Right checkedRows
456 pattern@(A.At region _) : rest ->
457 let nextRow = [simplify pattern] in
458 if isUseful checkedRows nextRow then
459 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
460 else
461 Left (Redundant overallRegion region (length checkedRows + 1))
464-- Check if a new row "vector" is useful given previous rows "matrix"
465isUseful :: [[Pattern]] -> [Pattern] -> Bool
466isUseful matrix vector =
467 case matrix of
468 [] ->
469 -- No rows are the same as the new vector! The vector is useful!
470 True
472 _ ->
473 case vector of
474 [] ->
475 -- There is nothing left in the new vector, but we still have
476 -- rows that match the same things. This is not a useful vector!
477 False
479 firstPattern : patterns ->
480 case firstPattern of
481 Ctor _ name args ->
482 -- keep checking rows that start with this Ctor or Anything
483 isUseful
484 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
485 (args ++ patterns)
487 Anything ->
488 -- check if all alts appear in matrix
489 case isComplete matrix of
490 No ->
491 -- This Anything is useful because some Ctors are missing.
492 -- But what if a previous row has an Anything?
493 -- If so, this one is not useful.
494 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
496 Yes alts ->
497 -- All Ctors are covered, so this Anything is not needed for any
498 -- of those. But what if some of those Ctors have subpatterns
499 -- that make them less general? If so, this actually is useful!
500 let
501 isUsefulAlt (Can.CtorAlt ctor arity) =
502 isUseful
503 (Maybe.mapMaybe (specializeRowByCtor ctor arity) matrix)
504 (replicate arity Anything ++ patterns)
505 in
506 any isUsefulAlt alts
508 Literal literal ->
509 -- keep checking rows that start with this Literal or Anything
510 isUseful
511 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
512 patterns
515-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
516specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]
517specializeRowByCtor ctorName arity row =
518 case row of
519 Ctor _ name args : patterns ->
520 if name == ctorName then
521 Just (args ++ patterns)
522 else
523 Nothing
525 Anything : patterns ->
526 Just (replicate arity Anything ++ patterns)
528 Literal _ : _ ->
529 error $
530 "Compiler bug! After type checking, constructors and literals\
531 \ should never align in pattern match exhaustiveness checks."
533 [] ->
534 error "Compiler error! Empty matrices should not get specialized."
537-- INVARIANT: (length row == N) ==> (length result == N-1)
538specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
539specializeRowByLiteral literal row =
540 case row of
541 Literal lit : patterns ->
542 if lit == literal then
543 Just patterns
544 else
545 Nothing
547 Anything : patterns ->
548 Just patterns
550 Ctor _ _ _ : _ ->
551 error $
552 "Compiler bug! After type checking, constructors and literals\
553 \ should never align in pattern match exhaustiveness checks."
555 [] ->
556 error "Compiler error! Empty matrices should not get specialized."
559-- INVARIANT: (length row == N) ==> (length result == N-1)
560specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
561specializeRowByAnything row =
562 case row of
563 [] ->
564 Nothing
566 Ctor _ _ _ : _ ->
567 Nothing
569 Anything : patterns ->
570 Just patterns
572 Literal _ : _ ->
573 Nothing
577-- ALL CONSTRUCTORS ARE PRESENT?
580data Complete
581 = Yes [Can.CtorAlt]
582 | No
585isComplete :: [[Pattern]] -> Complete
586isComplete matrix =
587 let
588 ctors = collectCtors matrix
589 numSeen = Map.size ctors
590 in
591 if numSeen == 0 then
592 No
593 else
594 let (Can.CtorAlts numAlts alts) = snd (Map.findMin ctors) in
595 if numSeen == numAlts then Yes alts else No
599-- COLLECT CTORS
602collectCtors :: [[Pattern]] -> Map.Map N.Name Can.CtorAlts
603collectCtors matrix =
604 List.foldl' collectCtorsHelp Map.empty matrix
607collectCtorsHelp :: Map.Map N.Name Can.CtorAlts -> [Pattern] -> Map.Map N.Name Can.CtorAlts
608collectCtorsHelp ctors row =
609 case row of
610 Ctor alts name _ : _ ->
611 Map.insert name alts ctors
613 _ ->
614 ctors