@@ -26,89 +26,96 @@ import qualified AST.Variable as Var
2626import qualified Reporting.Error.CheckMatch as Error
2727import Reporting.Warning.CheckMatch
2828
29−type M = Either (Annotation.Located Error.Error)
29+type M =
30+ Either (Annotation.Located Error.Error)
3031
3132
3233fromPattern :: CanonicalPattern -> CanonicalPat
33−fromPattern (Annotation.A _region p) = case p of
34− Pattern.Data ctor ps ->
35− Data ctor (map fromPattern ps)
34+fromPattern (Annotation.A _region p) =
35+ case p of
36+ Pattern.Data ctor ps ->
37+ Data ctor (map fromPattern ps)
3638
37− Pattern.Record fs ->
38− Record fs
39+ Pattern.Record fs ->
40+ Record fs
3941
40− Pattern.Alias s p ->
41− Alias s (fromPattern p)
42+ Pattern.Alias s p ->
43+ Alias s (fromPattern p)
4244
43− Pattern.Var s ->
44− Var s
45+ Pattern.Var s ->
46+ Var s
4547
46− Pattern.Anything ->
47− Anything
48+ Pattern.Anything ->
49+ Anything
4850
49− Pattern.Literal l ->
50− Literal l
51+ Pattern.Literal l ->
52+ Literal l
5153
5254
5355checkBody
5456 :: Module.Interfaces
5557 -> Module.CanonicalBody
5658 -> M [Annotation.Located Warning]
57−checkBody interfaces = checkExpr . Module.program where
59+checkBody interfaces =
60+ checkExpr . Module.program
61+ where
5862 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
59− checkExpr (Annotation.A r e) = case e of
60− General.ExplicitList es ->
61− concatMapM checkExpr es
63+ checkExpr (Annotation.A r e) =
64+ case e of
65+ General.ExplicitList es ->
66+ concatMapM checkExpr es
6267
63− General.Binop _ e e' ->
64− (++) <$> checkExpr e <*> checkExpr e'
68+ General.Binop _ e e' ->
69+ (++) <$> checkExpr e <*> checkExpr e'
6570
66− General.Lambda p e ->
67− maybeCons <$> checkMatch r [p] <*> checkExpr e
71+ General.Lambda p e ->
72+ maybeCons <$> checkMatch r [p] <*> checkExpr e
6873
69− General.App e e' ->
70− (++) <$> checkExpr e <*> checkExpr e'
74+ General.App e e' ->
75+ (++) <$> checkExpr e <*> checkExpr e'
7176
72− General.MultiIf branches ->
73− concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
77+ General.MultiIf branches ->
78+ concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
7479
75− General.Let defs e ->
76− concat <$> sequence [ps, rhssResults, checkExpr e]
77− where
78− ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
79− rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
80+ General.Let defs e ->
81+ concat <$> sequence [ps, rhssResults, checkExpr e]
82+ where
83+ ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
84+ rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
8085
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
86+ General.Case e branches ->
87+ do eResults <- checkExpr e
88+ result <- checkMatch r ps
89+ branchResults <- concatMapM (checkExpr . snd) branches
90+ return (eResults ++ maybeCons result branchResults)
91+ where ps = map fst branches
8792
88− General.Data _ctor es ->
89− concatMapM checkExpr es
93+ General.Data _ctor es ->
94+ concatMapM checkExpr es
9095
91− General.Access e _f ->
92− checkExpr e
96+ General.Access e _f ->
97+ checkExpr e
9398
94− General.Remove e _f ->
95− checkExpr e
99+ General.Remove e _f ->
100+ checkExpr e
96101
97− General.Insert e _f e' ->
98− (++) <$> checkExpr e <*> checkExpr e'
102+ General.Insert e _f e' ->
103+ (++) <$> checkExpr e <*> checkExpr e'
99104
100− General.Modify e _ ->
101− checkExpr e
105+ General.Modify e _ ->
106+ checkExpr e
102107
103− General.Record fields ->
104− concatMapM (checkExpr . snd) fields
108+ General.Record fields ->
109+ concatMapM (checkExpr . snd) fields
105110
106− _ ->
107− return []
111+ _ ->
112+ return []
108113
109114
110115 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
111− ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
116+ ctorToAdt =
117+ \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
118+ where
112119 -- Maps home to ctor name to the adt to which that ctor belongs
113120 m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
114121 m = builtins `Map.union` fromModules where
@@ -119,46 +126,59 @@ checkBody interfaces = checkExpr . Module.program where
119126
120127
121128 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
122− ctorToAdtErr region c = case ctorToAdt c of
123− Nothing ->
124− throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
129+ ctorToAdtErr region c =
130+ case ctorToAdt c of
131+ Nothing ->
132+ throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
125133
126− Just adt ->
127− return adt
134+ Just adt ->
135+ return adt
128136
129137
130138 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
131− complement region p = case p of
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) =
139− Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
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
150−
151− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
152− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
153−
154− return (otherCtorPatterns ++ argComplement)
155−
156− Record _fs -> return []
157− Alias _s p -> complement region p
158− Var _s -> return []
159− Anything -> return []
160− Literal l -> return [AnythingBut (Set.singleton l)]
161− AnythingBut ls -> return (map Literal (Set.toList ls))
139+ complement region p =
140+ case p of
141+ Data ctor ps ->
142+ do let ctorName = Var.name ctor
143+ ctorHome = Var.home ctor
144+ (_tyVars, ctors) <- ctorToAdtErr region ctor
145+ -- A pattern is in the complement of this one if it uses one of the
146+ -- other constructors of this type...
147+ let otherCtorPat (ctor', args) =
148+ Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
149+ (replicate (length args) Anything)
150+
151+ otherCtorPatterns =
152+ filter (\(ctor', _) -> ctor' /= ctorName) ctors
153+ |> map otherCtorPat
154+
155+ -- or if it uses this constructor and one of its argument patterns is
156+ -- in the complement of an argument pattern here.
157+ numArgs = length ps
158+ sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
159+
160+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
161+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
162+
163+ return (otherCtorPatterns ++ argComplement)
164+
165+ Record _fs ->
166+ return []
167+
168+ Alias _s p ->
169+ complement region p
170+
171+ Var _s ->
172+ return []
173+
174+ Anything ->
175+ return []
176+
177+ Literal l ->
178+ return [AnythingBut (Set.singleton l)]
179+
180+ AnythingBut ls ->
181+ return (map Literal (Set.toList ls))
162182
163183 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
164184 intersection p1 p2 =
@@ -205,7 +225,9 @@ checkBody interfaces = checkExpr . Module.program where
205225 _ -> Nothing
206226
207227 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
208− checkMatch region = go [Anything] where
228+ checkMatch region =
229+ go [Anything]
230+ where
209231 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
210232 go unhandled ps =
211233 case (unhandled, ps) of
@@ -227,13 +249,16 @@ checkBody interfaces = checkExpr . Module.program where
227249
228250-- Util
229251concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
230−concatMapM f = liftM concat . mapM f
252+concatMapM f =
253+ liftM concat . mapM f
231254
232255
233256mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
234−mapMaybeM f = liftM catMaybes . mapM f
257+mapMaybeM f =
258+ liftM catMaybes . mapM f
235259
236260
237261maybeCons :: Maybe a -> [a] -> [a]
238−maybeCons = maybe id (:)
262+maybeCons =
263+ maybe id (:)
239264