git.iko.soy/elk
on master help sign in
style
ed7f3ffIzaak Meckler
src/CheckMatch.hs+166−88
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ import Data.Maybe (mapMaybe, catMaybes)
14import qualified Data.Set as Set
14import qualified Data.Set as Set
15import qualified Data.Map as Map
15import qualified Data.Map as Map
16
16
17+import Elm.Utils ((|>))
17import qualified AST.Expression.General as General
18import qualified AST.Expression.General as General
18import qualified AST.Expression.Canonical as Canonical
19import qualified AST.Expression.Canonical as Canonical
19import qualified AST.Module as Module
20import qualified AST.Module as Module
@@ -25,25 +26,30 @@ import qualified AST.Variable as Var
25import qualified Reporting.Error.CheckMatch as Error
26import qualified Reporting.Error.CheckMatch as Error
26import Reporting.Warning.CheckMatch
27import Reporting.Warning.CheckMatch
27
28
29+type M = Either (Annotation.Located Error.Error)
30+
31+
28fromPattern :: CanonicalPattern -> CanonicalPat
32fromPattern :: CanonicalPattern -> CanonicalPat
29fromPattern (Annotation.A _region p) = case p of
33fromPattern (Annotation.A _region p) = case p of
30− Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
34+ Pattern.Data ctor ps ->
31− Pattern.Record fs -> Record fs
35+ Data ctor (map fromPattern ps)
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
36
36
37−concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
37+ Pattern.Record fs ->
38−concatMapM f = liftM concat . mapM f
38+ Record fs
39
39
40−mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
40+ Pattern.Alias s p ->
41−mapMaybeM f = liftM catMaybes . mapM f
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
42
51
43−maybeCons :: Maybe a -> [a] -> [a]
44−maybeCons = maybe id (:)
45
52
46−type M = Either (Annotation.Located Error.Error)
47checkBody
53checkBody
48 :: Module.Interfaces
54 :: Module.Interfaces
49 -> Module.CanonicalBody
55 -> Module.CanonicalBody
@@ -51,68 +57,101 @@ checkBody
51checkBody interfaces = checkExpr . Module.program where
57checkBody interfaces = checkExpr . Module.program where
52 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
58 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
53 checkExpr (Annotation.A r e) = case e of
59 checkExpr (Annotation.A r e) = case e of
54− General.ExplicitList es -> concatMapM checkExpr es
60+ General.ExplicitList es ->
55− General.Binop _ e e' -> (++) <$> checkExpr e <*> checkExpr e'
61+ concatMapM checkExpr es
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
59
62
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 ->
60− General.Let defs e -> fmap concat $ sequence [ps, rhssResults, checkExpr e]
76+ concat <$> sequence [ps, rhssResults, checkExpr e]
61 where
77 where
62 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
78 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
63 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
79 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
64
80
65− General.Case e branches -> do
81+ General.Case e branches ->
66− eResults <- checkExpr e
82+ do eResults <- checkExpr e
67− result <- checkMatch r ps
83+ result <- checkMatch r ps
68− branchResults <- concatMapM (checkExpr . snd) branches
84+ branchResults <- concatMapM (checkExpr . snd) branches
69− return (eResults ++ maybeCons result branchResults)
85+ return (eResults ++ maybeCons result branchResults)
70− where ps = map fst branches
86+ where ps = map fst branches
71−
87+
88+ General.Data _ctor es ->
72− General.Data _ctor es -> concatMapM checkExpr es
89+ concatMapM checkExpr es
90+
73− General.Access e _f -> checkExpr e
91+ General.Access e _f ->
92+ checkExpr e
93+
74− General.Remove e _f -> checkExpr e
94+ General.Remove e _f ->
95+ checkExpr e
96+
97+ General.Insert e _f e' ->
75− General.Insert e _f e' -> (++) <$> checkExpr e <*> checkExpr e'
98+ (++) <$> checkExpr e <*> checkExpr e'
99+
76− General.Modify e _ -> checkExpr e
100+ General.Modify e _ ->
101+ checkExpr e
102+
103+ General.Record fields ->
77− General.Record fields -> concatMapM (checkExpr . snd) fields
104+ concatMapM (checkExpr . snd) fields
105+
106+ _ ->
78− General.Port _pi -> return []
107+ return []
79− _ -> return []
108+
80
109
81 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
110 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
82 ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
111 ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
112+ -- Maps home to ctor name to the adt to which that ctor belongs
83− m :: Map.Map Var.Home (Map.Map String {- ctor name -} (Module.AdtInfo String))
113+ m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
84 m = builtins `Map.union` fromModules where
114 m = builtins `Map.union` fromModules where
115+ -- TODO
85− builtins = Map.empty -- TODO
116+ builtins = Map.empty
117+
118+ fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
86
119
87− fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
88
120
89 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
121 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
90 ctorToAdtErr region c = case ctorToAdt c of
122 ctorToAdtErr region c = case ctorToAdt c of
123+ Nothing ->
91− Nothing -> throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
124+ throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
125+
126+ Just adt ->
92− Just adt -> return adt
127+ return adt
128+
93
129
94 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
130 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
95 complement region p = case p of
131 complement region p = case p of
96− Data ctor ps -> do
132+ Data ctor ps ->
97− let ctorName = Var.name ctor
133+ do let ctorName = Var.name ctor
98− ctorHome = Var.home ctor
134+ ctorHome = Var.home ctor
99− (_tyVars, ctors) <- ctorToAdtErr region ctor
135+ (_tyVars, ctors) <- ctorToAdtErr region ctor
100− -- A pattern is in the complement of this one if it uses one of the
136+ -- A pattern is in the complement of this one if it uses one of the
101− -- other constructors of this type...
137+ -- other constructors of this type...
102− let otherCtorPatterns =
103− map (\(ctor',args) ->
138+ let otherCtorPat (ctor', args) =
104 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
139 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
105− (replicate (length args) Anything))
140+ (replicate (length args) Anything)
141+
142+ otherCtorPatterns =
106− $ filter (\(ctor', _) -> ctor' /= ctorName) ctors
143+ filter (\(ctor', _) -> ctor' /= ctorName) ctors
144+ |> map otherCtorPat
145+
107− -- or if it uses this constructor and one of its argument patterns is
146+ -- or if it uses this constructor and one of its argument patterns is
108− -- in the complement of an argument pattern here.
147+ -- in the complement of an argument pattern here.
109− numArgs = length ps
148+ numArgs = length ps
110− sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
149+ sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
111
150
112− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
151+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
113− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
152+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
114
153
115− return (otherCtorPatterns ++ argComplement)
154+ return (otherCtorPatterns ++ argComplement)
116
155
117 Record _fs -> return []
156 Record _fs -> return []
118 Alias _s p -> complement region p
157 Alias _s p -> complement region p
@@ -122,40 +161,79 @@ checkBody interfaces = checkExpr . Module.program where
122 AnythingBut ls -> return (map Literal (Set.toList ls))
161 AnythingBut ls -> return (map Literal (Set.toList ls))
123
162
124 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
163 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
125− intersection p1 p2 = case (p1, p2) of
164+ intersection p1 p2 =
165+ case (p1, p2) of
166+ (Alias _ p1', _) ->
126− (Alias _ p1', _) -> intersection p1' p2
167+ intersection p1' p2
168+
169+ (_, Alias _ p2') ->
127− (_, Alias _ p2') -> intersection p1 p2'
170+ intersection p1 p2'
171+
128− (Anything, _) -> Just p2
172+ (Anything, _) ->
173+ Just p2
174+
175+ (Var _, _) ->
129− (Var _, _) -> Just p2
176+ Just p2
177+
130− (_, Anything) -> Just p1
178+ (_, Anything) ->
179+ Just p1
180+
181+ (_, Var _) ->
131− (_, Var _) -> Just p1
182+ Just p1
132−
183+
133− (Data ctor1 args1, Data ctor2 args2) ->
184+ (Data ctor1 args1, Data ctor2 args2) ->
134− if ctor1 /= ctor2
185+ if ctor1 /= ctor2
135− then Nothing
186+ 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))
187+ else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
138−
188+
139− -- TODO Assuming the fields are identical.
189+ -- TODO Assuming the fields are identical.
140− (Record _fs, Record _) -> Just p1
190+ (Record _fs, Record _) ->
191+ Just p1
192+
193+ (Literal l1, Literal l2) ->
141− (Literal l1, Literal l2) -> if l1 == l2 then Just p1 else Nothing
194+ if l1 == l2 then Just p1 else Nothing
195+
196+ (AnythingBut ls, Literal l) ->
142− (AnythingBut ls, Literal l) -> if l `Set.member` ls then Nothing else Just p2
197+ if l `Set.member` ls then Nothing else Just p2
198+
199+ (Literal l, AnythingBut ls) ->
143− (Literal l, AnythingBut ls) -> if l `Set.member` ls then Nothing else Just p1
200+ if l `Set.member` ls then Nothing else Just p1
201+
202+ (AnythingBut ls1, AnythingBut ls2) ->
144− (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
203+ Just (AnythingBut (Set.union ls1 ls2))
204+
145− _ -> Nothing
205+ _ -> Nothing
146
206
147 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
207 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
148 checkMatch region = go [Anything] where
208 checkMatch region = go [Anything] where
149 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
209 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
210+ go unhandled ps =
211+ case (unhandled, ps) of
212+ ([], []) ->
150− go [] [] = return Nothing
213+ return Nothing
214+
215+ (_:_, []) ->
151− go qs@(_:_) [] = return (Just (Annotation.A region (Inexhaustive qs)))
216+ return (Just (Annotation.A region (Inexhaustive unhandled)))
152− go unhandled (p:ps) =
217+
218+ (_, p:ps') ->
153− let pp = fromPattern p
219+ let pp = fromPattern p
154− Annotation.A region _ = p
220+ Annotation.A region _ = p
155− in
221+ in
156− if all (\q -> intersection q pp == Nothing) unhandled
222+ if all (\q -> intersection q pp == Nothing) unhandled
157− then return (Just (Annotation.A region (Redundant p)))
223+ then return (Just (Annotation.A region (Redundant p)))
158− else do
224+ else
159− pComp <- complement region pp
225+ do pComp <- complement region pp
160− go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps
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 (:)
161
239