git.iko.soy/elk
on e41ae10 help sign in
elk/src/Nitpick/PatternMatches.hs
611 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.Arg -> [Error] -> [Error]
221checkArg (Can.Arg _ pattern@(A.At region _)) errors =
222 checkPatterns region BadArg [pattern] errors
225checkTypedArg :: Can.TypedArg -> [Error] -> [Error]
226checkTypedArg (Can.TypedArg _ _ 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.VarOperator _ _ _ _ ->
250 errors
252 Can.Chr _ ->
253 errors
255 Can.Str _ ->
256 errors
258 Can.Int _ ->
259 errors
261 Can.Float _ ->
262 errors
264 Can.List entries ->
265 foldr checkExpr errors entries
267 Can.Negate expr ->
268 checkExpr expr errors
270 Can.Binop _ _ _ _ left right ->
271 checkExpr left $
272 checkExpr right errors
274 Can.Lambda args _ body ->
275 foldr checkArg (checkExpr body errors) args
277 Can.Call func args ->
278 checkExpr func $ foldr checkExpr errors args
280 Can.If branches finally ->
281 foldr checkIfBranch (checkExpr finally errors) branches
283 Can.Let def body ->
284 checkDef def $ checkExpr body errors
286 Can.LetRec defs body ->
287 foldr checkDef (checkExpr body errors) defs
289 Can.LetDestruct pattern@(A.At reg _) _ expr body ->
290 checkPatterns reg BadDestruct [pattern] $
291 checkExpr expr $ checkExpr body errors
293 Can.Case expr branches ->
294 checkExpr expr $ checkCases region branches errors
296 Can.Accessor _ ->
297 errors
299 Can.Access record _ ->
300 checkExpr record errors
302 Can.Update record fields ->
303 checkExpr record $ Map.foldr checkExpr errors fields
305 Can.Record fields ->
306 Map.foldr checkExpr errors fields
308 Can.Unit ->
309 errors
311 Can.Tuple a b maybeC ->
312 checkExpr a $
313 checkExpr b $
314 case maybeC of
315 Nothing ->
316 errors
318 Just c ->
319 checkExpr c errors
321 Can.Shader _ _ _ ->
322 errors
326-- CHECK IF BRANCH
329checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
330checkIfBranch (condition, branch) errs =
331 checkExpr condition $ checkExpr branch errs
335-- CHECK CASE EXPRESSION
338checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]
339checkCases region branches errors =
340 let
341 (patterns, newErrors) =
342 foldr checkCaseBranch ([], errors) branches
343 in
344 checkPatterns region BadCase patterns newErrors
347checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
348checkCaseBranch (Can.CaseBranch pattern _ expr) (patterns, errors) =
349 ( pattern:patterns
350 , checkExpr expr errors
351 )
355-- CHECK PATTERNS
358checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
359checkPatterns region context patterns errors =
360 case toNonRedundantRows region patterns of
361 Left err ->
362 err:errors
364 Right matrix ->
365 case isExhaustive matrix 1 of
366 [] ->
367 errors
369 badPatterns ->
370 Incomplete region context (map head badPatterns) : errors
374-- EXHAUSTIVE PATTERNS
377-- INVARIANTS:
378--
379-- The initial rows "matrix" are all of length 1
380-- The initial count of items per row "n" is also 1
381-- The resulting rows are examples of missing patterns
382--
383isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
384isExhaustive matrix n =
385 case matrix of
386 [] ->
387 [replicate n Anything]
389 _ ->
390 if n == 0 then
391 []
392 else
393 let
394 ctors = collectCtors matrix
395 numSeen = Map.size ctors
396 in
397 if numSeen == 0 then
398 (:) Anything
399 <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
401 else
402 let alts@(Can.CtorAlts numAlts altList) = snd (Map.findMin ctors) in
403 if numSeen < numAlts then
404 (:)
405 <$> Maybe.mapMaybe (isMissing alts ctors) altList
406 <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)
408 else
409 let
410 isAltExhaustive (Can.CtorAlt name arity) =
411 recoverCtor alts name arity <$>
412 isExhaustive
413 (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
414 (arity + n - 1)
415 in
416 concatMap isAltExhaustive altList
419isMissing :: Can.CtorAlts -> Map.Map N.Name a -> Can.CtorAlt -> Maybe Pattern
420isMissing alts ctors (Can.CtorAlt name arity) =
421 if Map.member name ctors then
422 Nothing
423 else
424 Just (Ctor alts name (replicate arity Anything))
427recoverCtor :: Can.CtorAlts -> N.Name -> Int -> [Pattern] -> [Pattern]
428recoverCtor alts name arity patterns =
429 let
430 (args, rest) =
431 splitAt arity patterns
432 in
433 Ctor alts name args : rest
437-- REDUNDANT PATTERNS
440-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
441toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]
442toNonRedundantRows region patterns =
443 toSimplifiedUsefulRows region [] patterns
446-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
447toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
448toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
449 case uncheckedPatterns of
450 [] ->
451 Right checkedRows
453 pattern@(A.At region _) : rest ->
454 let nextRow = [simplify pattern] in
455 if isUseful checkedRows nextRow then
456 toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
457 else
458 Left (Redundant overallRegion region (length checkedRows + 1))
461-- Check if a new row "vector" is useful given previous rows "matrix"
462isUseful :: [[Pattern]] -> [Pattern] -> Bool
463isUseful matrix vector =
464 case matrix of
465 [] ->
466 -- No rows are the same as the new vector! The vector is useful!
467 True
469 _ ->
470 case vector of
471 [] ->
472 -- There is nothing left in the new vector, but we still have
473 -- rows that match the same things. This is not a useful vector!
474 False
476 firstPattern : patterns ->
477 case firstPattern of
478 Ctor _ name args ->
479 -- keep checking rows that start with this Ctor or Anything
480 isUseful
481 (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
482 (args ++ patterns)
484 Anything ->
485 -- check if all alts appear in matrix
486 case isComplete matrix of
487 No ->
488 -- This Anything is useful because some Ctors are missing.
489 -- But what if a previous row has an Anything?
490 -- If so, this one is not useful.
491 isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns
493 Yes alts ->
494 -- All Ctors are covered, so this Anything is not needed for any
495 -- of those. But what if some of those Ctors have subpatterns
496 -- that make them less general? If so, this actually is useful!
497 let
498 isUsefulAlt (Can.CtorAlt ctor arity) =
499 isUseful
500 (Maybe.mapMaybe (specializeRowByCtor ctor arity) matrix)
501 (replicate arity Anything ++ patterns)
502 in
503 any isUsefulAlt alts
505 Literal literal ->
506 -- keep checking rows that start with this Literal or Anything
507 isUseful
508 (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
509 patterns
512-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
513specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]
514specializeRowByCtor ctorName arity row =
515 case row of
516 Ctor _ name args : patterns ->
517 if name == ctorName then
518 Just (args ++ patterns)
519 else
520 Nothing
522 Anything : patterns ->
523 Just (replicate arity Anything ++ patterns)
525 Literal _ : _ ->
526 error $
527 "Compiler bug! After type checking, constructors and literals\
528 \ should never align in pattern match exhaustiveness checks."
530 [] ->
531 error "Compiler error! Empty matrices should not get specialized."
534-- INVARIANT: (length row == N) ==> (length result == N-1)
535specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
536specializeRowByLiteral literal row =
537 case row of
538 Literal lit : patterns ->
539 if lit == literal then
540 Just patterns
541 else
542 Nothing
544 Anything : patterns ->
545 Just patterns
547 Ctor _ _ _ : _ ->
548 error $
549 "Compiler bug! After type checking, constructors and literals\
550 \ should never align in pattern match exhaustiveness checks."
552 [] ->
553 error "Compiler error! Empty matrices should not get specialized."
556-- INVARIANT: (length row == N) ==> (length result == N-1)
557specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
558specializeRowByAnything row =
559 case row of
560 [] ->
561 Nothing
563 Ctor _ _ _ : _ ->
564 Nothing
566 Anything : patterns ->
567 Just patterns
569 Literal _ : _ ->
570 Nothing
574-- ALL CONSTRUCTORS ARE PRESENT?
577data Complete
578 = Yes [Can.CtorAlt]
579 | No
582isComplete :: [[Pattern]] -> Complete
583isComplete matrix =
584 let
585 ctors = collectCtors matrix
586 numSeen = Map.size ctors
587 in
588 if numSeen == 0 then
589 No
590 else
591 let (Can.CtorAlts numAlts alts) = snd (Map.findMin ctors) in
592 if numSeen == numAlts then Yes alts else No
596-- COLLECT CTORS
599collectCtors :: [[Pattern]] -> Map.Map N.Name Can.CtorAlts
600collectCtors matrix =
601 List.foldl' collectCtorsHelp Map.empty matrix
604collectCtorsHelp :: Map.Map N.Name Can.CtorAlts -> [Pattern] -> Map.Map N.Name Can.CtorAlts
605collectCtorsHelp ctors row =
606 case row of
607 Ctor info name _ : _ ->
608 Map.insert name info ctors
610 _ ->
611 ctors