@@ -0,0 +1,158 @@
1+{-# LANGUAGE NamedFieldPuns #-}
8+import Control.Applicative ((<$>))
9+import qualified AST.Expression.General as General
10+import qualified AST.Expression.Canonical as Canonical
12+import qualified AST.Pattern as Pattern
13+import AST.Pattern (CanonicalPattern)
14+import qualified AST.Annotation as Annotation
15+import qualified Data.Map as Map
16+import qualified AST.Variable as Var
17+import qualified AST.Literal as Literal
18+import Data.Maybe (mapMaybe)
19+import Control.Monad (forM)
20+import qualified Data.Set as Set
23+ = Redundant CanonicalPattern
24+ | Inexhaustive CanonicalPat
31+ | Alias String (Pat var)
34+ | Literal Literal.Literal
35+ -- It's a shame that I had to replicate the entire pattern type, but it's
36+ -- essential to have this constructor.
37+ | AnythingBut (Set.Set Literal.Literal)
38+ deriving (Show, Eq, Ord)
40+type CanonicalPat = Pat Var.Canonical
42+fromPattern :: CanonicalPattern -> CanonicalPat
43+fromPattern p = case p of
44+ Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
45+ Pattern.Record fs -> Record fs
46+ Pattern.Alias s p -> Alias s (fromPattern p)
47+ Pattern.Var s -> Var s
48+ Pattern.Anything -> Anything
49+ Pattern.Literal l -> Literal l
51+data ErrorType = ConstructorNotFound Var.Canonical
53+checkModule :: [CanonicalAdt] -> Module exports CanonicalBody -> [(Either ErrorType MatchResult, Annotation.Region)]
54+checkModule adts (Module {body}) = checkBody body where
55+ checkBody :: CanonicalBody -> [(Either ErrorType MatchResult, Annotation.Region)]
56+ checkBody (CanonicalBody {program}) = checkExpr program
58+ checkExpr :: Canonical.Expr -> [(Either ErrorType MatchResult, Annotation.Region)]
59+ checkExpr (Annotation.A r e) = case e of
60+ General.ExplicitList es -> concatMap checkExpr es
61+ General.Binop _ e e' -> checkExpr e ++ checkExpr e'
62+ General.Lambda p e -> (checkMatch [p], r) : checkExpr e
63+ General.App e e' -> checkExpr e ++ checkExpr e'
64+ General.MultiIf branches -> concatMap (\(b,e) -> checkExpr b ++ checkExpr e) branches
66+ General.Let defs e -> ps ++ rhssResults ++ checkExpr e
68+ ps = map (\(Canonical.Definition p _ _) -> (checkMatch [p], r)) defs
69+ rhssResults = concatMap (\(Canonical.Definition _ e _) -> checkExpr e) defs
71+ General.Case e branches ->
72+ (checkMatch ps, r) : checkExpr e ++ concatMap (checkExpr . snd) branches
73+ where ps = map fst branches
75+ General.Data _ctor es -> concatMap checkExpr es
76+ General.Access e _f -> checkExpr e
77+ General.Remove e _f -> checkExpr e
78+ General.Insert e _f e' -> checkExpr e ++ checkExpr e'
79+ General.Modify e _ -> checkExpr e
80+ General.Record fields -> concatMap (checkExpr . snd) fields
81+ General.Port _pi -> []
84+ ctorToAdt :: Var.Canonical -> Maybe CanonicalAdt
85+ ctorToAdt = \k -> Map.lookup k m where
87+ Map.fromList $ concatMap (\adt@(_adtName, (_tyVars, ctors)) ->
88+ map (\(ctor,_args) -> (ctor, adt)) ctors)
91+ ctorToAdtExn :: Var.Canonical -> Either ErrorType CanonicalAdt
92+ ctorToAdtExn c = case ctorToAdt c of
93+ Nothing -> Left (ConstructorNotFound c)
94+ Just adt -> Right adt
96+ complement :: CanonicalPat -> Either ErrorType [CanonicalPat]
97+ complement p = case p of
99+ (_adtName, (_tyVars, ctors)) <- ctorToAdtExn ctor
100+ -- A pattern is in the complement of this one if it uses one of the
101+ -- other constructors of this type...
102+ let otherCtorPatterns =
103+ map (\(ctor',args) ->
104+ Data ctor' (replicate (length args) Anything))
105+ (filter (\(ctor', _) -> ctor' /= ctor) ctors)
106+ -- or if it uses this constructor and one of its argument patterns is
107+ -- in the complement of an argument pattern here.
109+ sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
111+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
112+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement argP)
114+ return (otherCtorPatterns ++ argComplement)
116+ Record _fs -> return []
117+ Alias _s p -> complement p
119+ Anything -> return []
120+ Literal l -> return [AnythingBut (Set.singleton l)]
121+ AnythingBut ls -> return (map Literal (Set.toList ls))
123+ intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
124+ intersection p1 p2 = case (p1, p2) of
125+ (Alias _ p1', _) -> intersection p1' p2
126+ (_, Alias _ p2') -> intersection p1 p2'
127+ (Anything, _) -> Just p2
128+ (Var _, _) -> Just p2
129+ (_, Anything) -> Just p1
130+ (_, Var _) -> Just p1
132+ (Data ctor1 args1, Data ctor2 args2) ->
135+ -- TODO: Assumes that args must be the same length. I think that's ok.
136+ else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
138+ -- TODO Assuming the fields are identical.
139+ (Record _fs, Record _) -> Just p1
140+ (Literal l1, Literal l2) -> if l1 == l2 then Just p1 else Nothing
141+ (AnythingBut ls, Literal l) -> if l `Set.member` ls then Nothing else Just p2
142+ (Literal l, AnythingBut ls) -> if l `Set.member` ls then Nothing else Just p1
143+ (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
146+ checkMatch :: [CanonicalPattern] -> Either ErrorType MatchResult
147+ checkMatch = go [Anything] where
148+ go :: [CanonicalPat] -> [CanonicalPattern] -> Either ErrorType MatchResult
149+ go [] [] = return Ok
150+ go (q:_) [] = return (Inexhaustive q)
151+ go unhandled (p:ps) =
152+ let pp = fromPattern p in
153+ if all (\q -> intersection q pp == Nothing) unhandled
154+ then return (Redundant p)
156+ pComp <- complement pp
157+ go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps