git.iko.soy/elk
on master help sign in
more style
504b04cIzaak Meckler
src/CheckMatch.hs+117−92
compare with master
unifiedsplit
@@ -26,89 +26,96 @@ import qualified AST.Variable as Var
26import qualified Reporting.Error.CheckMatch as Error
26import qualified Reporting.Error.CheckMatch as Error
27import Reporting.Warning.CheckMatch
27import Reporting.Warning.CheckMatch
28
28
29+type M =
29−type M = Either (Annotation.Located Error.Error)
30+ Either (Annotation.Located Error.Error)
30
31
31
32
32fromPattern :: CanonicalPattern -> CanonicalPat
33fromPattern :: CanonicalPattern -> CanonicalPat
33−fromPattern (Annotation.A _region p) = case p of
34+fromPattern (Annotation.A _region p) =
35+ case p of
34− Pattern.Data ctor ps ->
36+ Pattern.Data ctor ps ->
35− Data ctor (map fromPattern ps)
37+ Data ctor (map fromPattern ps)
36
38
37− Pattern.Record fs ->
39+ Pattern.Record fs ->
38− Record fs
40+ Record fs
39
41
40− Pattern.Alias s p ->
42+ Pattern.Alias s p ->
41− Alias s (fromPattern p)
43+ Alias s (fromPattern p)
42
44
43− Pattern.Var s ->
45+ Pattern.Var s ->
44− Var s
46+ Var s
45
47
46− Pattern.Anything ->
48+ Pattern.Anything ->
47− Anything
49+ Anything
48
50
49− Pattern.Literal l ->
51+ Pattern.Literal l ->
50− Literal l
52+ Literal l
51
53
52
54
53checkBody
55checkBody
54 :: Module.Interfaces
56 :: Module.Interfaces
55 -> Module.CanonicalBody
57 -> Module.CanonicalBody
56 -> M [Annotation.Located Warning]
58 -> M [Annotation.Located Warning]
59+checkBody interfaces =
57−checkBody interfaces = checkExpr . Module.program where
60+ checkExpr . Module.program
61+ where
58 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
62 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
59− checkExpr (Annotation.A r e) = case e of
63+ checkExpr (Annotation.A r e) =
64+ case e of
60− General.ExplicitList es ->
65+ General.ExplicitList es ->
61− concatMapM checkExpr es
66+ concatMapM checkExpr es
62
67
63− General.Binop _ e e' ->
68+ General.Binop _ e e' ->
64− (++) <$> checkExpr e <*> checkExpr e'
69+ (++) <$> checkExpr e <*> checkExpr e'
65
70
66− General.Lambda p e ->
71+ General.Lambda p e ->
67− maybeCons <$> checkMatch r [p] <*> checkExpr e
72+ maybeCons <$> checkMatch r [p] <*> checkExpr e
68
73
69− General.App e e' ->
74+ General.App e e' ->
70− (++) <$> checkExpr e <*> checkExpr e'
75+ (++) <$> checkExpr e <*> checkExpr e'
71
76
72− General.MultiIf branches ->
77+ General.MultiIf branches ->
73− concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
78+ concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
74
79
75− General.Let defs e ->
80+ General.Let defs e ->
76− concat <$> sequence [ps, rhssResults, checkExpr e]
81+ concat <$> sequence [ps, rhssResults, checkExpr e]
77− where
82+ where
78− ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
83+ ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
79− rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
84+ rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
80
85
81− General.Case e branches ->
86+ General.Case e branches ->
82− do eResults <- checkExpr e
87+ do eResults <- checkExpr e
83− result <- checkMatch r ps
88+ result <- checkMatch r ps
84− branchResults <- concatMapM (checkExpr . snd) branches
89+ branchResults <- concatMapM (checkExpr . snd) branches
85− return (eResults ++ maybeCons result branchResults)
90+ return (eResults ++ maybeCons result branchResults)
86− where ps = map fst branches
91+ where ps = map fst branches
87
92
88− General.Data _ctor es ->
93+ General.Data _ctor es ->
89− concatMapM checkExpr es
94+ concatMapM checkExpr es
90
95
91− General.Access e _f ->
96+ General.Access e _f ->
92− checkExpr e
97+ checkExpr e
93
98
94− General.Remove e _f ->
99+ General.Remove e _f ->
95− checkExpr e
100+ checkExpr e
96
101
97− General.Insert e _f e' ->
102+ General.Insert e _f e' ->
98− (++) <$> checkExpr e <*> checkExpr e'
103+ (++) <$> checkExpr e <*> checkExpr e'
99
104
100− General.Modify e _ ->
105+ General.Modify e _ ->
101− checkExpr e
106+ checkExpr e
102
107
103− General.Record fields ->
108+ General.Record fields ->
104− concatMapM (checkExpr . snd) fields
109+ concatMapM (checkExpr . snd) fields
105
110
106− _ ->
111+ _ ->
107− return []
112+ return []
108
113
109
114
110 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
115 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
116+ ctorToAdt =
111− ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
117+ \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
118+ where
112 -- Maps home to ctor name to the adt to which that ctor belongs
119 -- 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))
120 m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
114 m = builtins `Map.union` fromModules where
121 m = builtins `Map.union` fromModules where
@@ -119,46 +126,59 @@ checkBody interfaces = checkExpr . Module.program where
119
126
120
127
121 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
128 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
122− ctorToAdtErr region c = case ctorToAdt c of
129+ ctorToAdtErr region c =
130+ case ctorToAdt c of
123− Nothing ->
131+ Nothing ->
124− throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
132+ throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
125
133
126− Just adt ->
134+ Just adt ->
127− return adt
135+ return adt
128
136
129
137
130 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
138 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
131− complement region p = case p of
139+ complement region p =
140+ case p of
132− Data ctor ps ->
141+ Data ctor ps ->
133− do let ctorName = Var.name ctor
142+ do let ctorName = Var.name ctor
134− ctorHome = Var.home ctor
143+ ctorHome = Var.home ctor
135− (_tyVars, ctors) <- ctorToAdtErr region ctor
144+ (_tyVars, ctors) <- ctorToAdtErr region ctor
136− -- A pattern is in the complement of this one if it uses one of the
145+ -- A pattern is in the complement of this one if it uses one of the
137− -- other constructors of this type...
146+ -- other constructors of this type...
138− let otherCtorPat (ctor', args) =
147+ let otherCtorPat (ctor', args) =
139− Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
148+ Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
140− (replicate (length args) Anything)
149+ (replicate (length args) Anything)
141−
150+
142− otherCtorPatterns =
151+ otherCtorPatterns =
143− filter (\(ctor', _) -> ctor' /= ctorName) ctors
152+ filter (\(ctor', _) -> ctor' /= ctorName) ctors
144− |> map otherCtorPat
153+ |> map otherCtorPat
145−
154+
146− -- or if it uses this constructor and one of its argument patterns is
155+ -- or if it uses this constructor and one of its argument patterns is
147− -- in the complement of an argument pattern here.
156+ -- in the complement of an argument pattern here.
148− numArgs = length ps
157+ numArgs = length ps
149− sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
158+ sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
150−
159+
151− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
160+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
152− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
161+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
153−
162+
154− return (otherCtorPatterns ++ argComplement)
163+ return (otherCtorPatterns ++ argComplement)
155−
164+
156− Record _fs -> return []
165+ Record _fs ->
166+ return []
167+
168+ Alias _s p ->
157− Alias _s p -> complement region p
169+ complement region p
170+
171+ Var _s ->
158− Var _s -> return []
172+ return []
173+
159− Anything -> return []
174+ Anything ->
175+ return []
176+
177+ Literal l ->
160− Literal l -> return [AnythingBut (Set.singleton l)]
178+ return [AnythingBut (Set.singleton l)]
179+
180+ AnythingBut ls ->
161− AnythingBut ls -> return (map Literal (Set.toList ls))
181+ return (map Literal (Set.toList ls))
162
182
163 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
183 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
164 intersection p1 p2 =
184 intersection p1 p2 =
@@ -205,7 +225,9 @@ checkBody interfaces = checkExpr . Module.program where
205 _ -> Nothing
225 _ -> Nothing
206
226
207 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
227 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
208− checkMatch region = go [Anything] where
228+ checkMatch region =
229+ go [Anything]
230+ where
209 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
231 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
210 go unhandled ps =
232 go unhandled ps =
211 case (unhandled, ps) of
233 case (unhandled, ps) of
@@ -227,13 +249,16 @@ checkBody interfaces = checkExpr . Module.program where
227
249
228-- Util
250-- Util
229concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
251concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
252+concatMapM f =
230−concatMapM f = liftM concat . mapM f
253+ liftM concat . mapM f
231
254
232
255
233mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
256mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
257+mapMaybeM f =
234−mapMaybeM f = liftM catMaybes . mapM f
258+ liftM catMaybes . mapM f
235
259
236
260
237maybeCons :: Maybe a -> [a] -> [a]
261maybeCons :: Maybe a -> [a] -> [a]
238−maybeCons = maybe id (:)
262+maybeCons =
263+ maybe id (:)
239
264