@@ -14,6 +14,7 @@ import Data.Maybe (mapMaybe, catMaybes)
1414import qualified Data.Set as Set
1515import qualified Data.Map as Map
1616
17+import Elm.Utils ((|>))
1718import qualified AST.Expression.General as General
1819import qualified AST.Expression.Canonical as Canonical
1920import qualified AST.Module as Module
@@ -25,25 +26,30 @@ import qualified AST.Variable as Var
2526import qualified Reporting.Error.CheckMatch as Error
2627import Reporting.Warning.CheckMatch
2728
29+type M = Either (Annotation.Located Error.Error)
30+
31+
2832fromPattern :: CanonicalPattern -> CanonicalPat
2933fromPattern (Annotation.A _region p) = case p of
30− Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
31− Pattern.Record fs -> Record fs
32− Pattern.Alias s p -> Alias s (fromPattern p)
33− Pattern.Var s -> Var s
34− Pattern.Anything -> Anything
35− Pattern.Literal l -> Literal l
34+ Pattern.Data ctor ps ->
35+ Data ctor (map fromPattern ps)
3636
37−concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
38−concatMapM f = liftM concat . mapM f
37+ Pattern.Record fs ->
38+ Record fs
3939
40−mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
41−mapMaybeM f = liftM catMaybes . mapM f
40+ Pattern.Alias s p ->
41+ Alias s (fromPattern p)
42+
43+ Pattern.Var s ->
44+ Var s
45+
46+ Pattern.Anything ->
47+ Anything
48+
49+ Pattern.Literal l ->
50+ Literal l
4251
43−maybeCons :: Maybe a -> [a] -> [a]
44−maybeCons = maybe id (:)
4552
46−type M = Either (Annotation.Located Error.Error)
4753checkBody
4854 :: Module.Interfaces
4955 -> Module.CanonicalBody
@@ -51,68 +57,101 @@ checkBody
5157checkBody interfaces = checkExpr . Module.program where
5258 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
5359 checkExpr (Annotation.A r e) = case e of
54− General.ExplicitList es -> concatMapM checkExpr es
55− General.Binop _ e e' -> (++) <$> checkExpr e <*> checkExpr e'
56− General.Lambda p e -> maybeCons <$> checkMatch r [p] <*> checkExpr e
57− General.App e e' -> (++) <$> checkExpr e <*> checkExpr e'
58− General.MultiIf branches -> concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
60+ General.ExplicitList es ->
61+ concatMapM checkExpr es
5962
60− General.Let defs e -> fmap concat $ sequence [ps, rhssResults, checkExpr e]
63+ General.Binop _ e e' ->
64+ (++) <$> checkExpr e <*> checkExpr e'
65+
66+ General.Lambda p e ->
67+ maybeCons <$> checkMatch r [p] <*> checkExpr e
68+
69+ General.App e e' ->
70+ (++) <$> checkExpr e <*> checkExpr e'
71+
72+ General.MultiIf branches ->
73+ concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
74+
75+ General.Let defs e ->
76+ concat <$> sequence [ps, rhssResults, checkExpr e]
6177 where
6278 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
6379 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
6480
65− General.Case e branches -> do
66− eResults <- checkExpr e
67− result <- checkMatch r ps
68− branchResults <- concatMapM (checkExpr . snd) branches
69− return (eResults ++ maybeCons result branchResults)
70− where ps = map fst branches
71−
72− General.Data _ctor es -> concatMapM checkExpr es
73− General.Access e _f -> checkExpr e
74− General.Remove e _f -> checkExpr e
75− General.Insert e _f e' -> (++) <$> checkExpr e <*> checkExpr e'
76− General.Modify e _ -> checkExpr e
77− General.Record fields -> concatMapM (checkExpr . snd) fields
78− General.Port _pi -> return []
79− _ -> return []
81+ General.Case e branches ->
82+ do eResults <- checkExpr e
83+ result <- checkMatch r ps
84+ branchResults <- concatMapM (checkExpr . snd) branches
85+ return (eResults ++ maybeCons result branchResults)
86+ where ps = map fst branches
87+
88+ General.Data _ctor es ->
89+ concatMapM checkExpr es
90+
91+ General.Access e _f ->
92+ checkExpr e
93+
94+ General.Remove e _f ->
95+ checkExpr e
96+
97+ General.Insert e _f e' ->
98+ (++) <$> checkExpr e <*> checkExpr e'
99+
100+ General.Modify e _ ->
101+ checkExpr e
102+
103+ General.Record fields ->
104+ concatMapM (checkExpr . snd) fields
105+
106+ _ ->
107+ return []
108+
80109
81110 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
82111 ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
83− m :: Map.Map Var.Home (Map.Map String {- ctor name -} (Module.AdtInfo String))
112+ -- Maps home to ctor name to the adt to which that ctor belongs
113+ m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
84114 m = builtins `Map.union` fromModules where
85− builtins = Map.empty -- TODO
115+ -- TODO
116+ builtins = Map.empty
117+
118+ fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
86119
87− fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
88120
89121 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
90122 ctorToAdtErr region c = case ctorToAdt c of
91− Nothing -> throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
92− Just adt -> return adt
123+ Nothing ->
124+ throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
125+
126+ Just adt ->
127+ return adt
128+
93129
94130 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
95131 complement region p = case p of
96− Data ctor ps -> do
97− let ctorName = Var.name ctor
98− ctorHome = Var.home ctor
99− (_tyVars, ctors) <- ctorToAdtErr region 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) ->
132+ Data ctor ps ->
133+ do let ctorName = Var.name ctor
134+ ctorHome = Var.home ctor
135+ (_tyVars, ctors) <- ctorToAdtErr region ctor
136+ -- A pattern is in the complement of this one if it uses one of the
137+ -- other constructors of this type...
138+ let otherCtorPat (ctor', args) =
104139 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
105− (replicate (length args) Anything))
106− $ filter (\(ctor', _) -> ctor' /= ctorName) ctors
107− -- or if it uses this constructor and one of its argument patterns is
108− -- in the complement of an argument pattern here.
109− numArgs = length ps
110− sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
140+ (replicate (length args) Anything)
141+
142+ otherCtorPatterns =
143+ filter (\(ctor', _) -> ctor' /= ctorName) ctors
144+ |> map otherCtorPat
145+
146+ -- or if it uses this constructor and one of its argument patterns is
147+ -- in the complement of an argument pattern here.
148+ numArgs = length ps
149+ sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
111150
112− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
113− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
151+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
152+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
114153
115− return (otherCtorPatterns ++ argComplement)
154+ return (otherCtorPatterns ++ argComplement)
116155
117156 Record _fs -> return []
118157 Alias _s p -> complement region p
@@ -122,40 +161,79 @@ checkBody interfaces = checkExpr . Module.program where
122161 AnythingBut ls -> return (map Literal (Set.toList ls))
123162
124163 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
125− intersection p1 p2 = case (p1, p2) of
126− (Alias _ p1', _) -> intersection p1' p2
127− (_, Alias _ p2') -> intersection p1 p2'
128− (Anything, _) -> Just p2
129− (Var _, _) -> Just p2
130− (_, Anything) -> Just p1
131− (_, Var _) -> Just p1
132−
133− (Data ctor1 args1, Data ctor2 args2) ->
134− if ctor1 /= ctor2
135− then Nothing
136− -- TODO: Assumes that args must be the same length. I think that's ok.
137− else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
138−
139− -- TODO Assuming the fields are identical.
140− (Record _fs, Record _) -> Just p1
141− (Literal l1, Literal l2) -> if l1 == l2 then Just p1 else Nothing
142− (AnythingBut ls, Literal l) -> if l `Set.member` ls then Nothing else Just p2
143− (Literal l, AnythingBut ls) -> if l `Set.member` ls then Nothing else Just p1
144− (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
145− _ -> Nothing
164+ intersection p1 p2 =
165+ case (p1, p2) of
166+ (Alias _ p1', _) ->
167+ intersection p1' p2
168+
169+ (_, Alias _ p2') ->
170+ intersection p1 p2'
171+
172+ (Anything, _) ->
173+ Just p2
174+
175+ (Var _, _) ->
176+ Just p2
177+
178+ (_, Anything) ->
179+ Just p1
180+
181+ (_, Var _) ->
182+ Just p1
183+
184+ (Data ctor1 args1, Data ctor2 args2) ->
185+ if ctor1 /= ctor2
186+ then Nothing
187+ else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
188+
189+ -- TODO Assuming the fields are identical.
190+ (Record _fs, Record _) ->
191+ Just p1
192+
193+ (Literal l1, Literal l2) ->
194+ if l1 == l2 then Just p1 else Nothing
195+
196+ (AnythingBut ls, Literal l) ->
197+ if l `Set.member` ls then Nothing else Just p2
198+
199+ (Literal l, AnythingBut ls) ->
200+ if l `Set.member` ls then Nothing else Just p1
201+
202+ (AnythingBut ls1, AnythingBut ls2) ->
203+ Just (AnythingBut (Set.union ls1 ls2))
204+
205+ _ -> Nothing
146206
147207 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
148208 checkMatch region = go [Anything] where
149209 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
150− go [] [] = return Nothing
151− go qs@(_:_) [] = return (Just (Annotation.A region (Inexhaustive qs)))
152− go unhandled (p:ps) =
153− let pp = fromPattern p
154− Annotation.A region _ = p
155− in
156− if all (\q -> intersection q pp == Nothing) unhandled
157− then return (Just (Annotation.A region (Redundant p)))
158− else do
159− pComp <- complement region pp
160− go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps
210+ go unhandled ps =
211+ case (unhandled, ps) of
212+ ([], []) ->
213+ return Nothing
214+
215+ (_:_, []) ->
216+ return (Just (Annotation.A region (Inexhaustive unhandled)))
217+
218+ (_, p:ps') ->
219+ let pp = fromPattern p
220+ Annotation.A region _ = p
221+ in
222+ if all (\q -> intersection q pp == Nothing) unhandled
223+ then return (Just (Annotation.A region (Redundant p)))
224+ else
225+ do pComp <- complement region pp
226+ go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps'
227+
228+-- Util
229+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
230+concatMapM f = liftM concat . mapM f
231+
232+
233+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
234+mapMaybeM f = liftM catMaybes . mapM f
235+
236+
237+maybeCons :: Maybe a -> [a] -> [a]
238+maybeCons = maybe id (:)
161239