git.iko.soy/elk
on master help sign in
Improve duplicate tracking a bit.
5fcbf86Evan Czaplicki
src/Canonicalize/Environment/Dups.hs+48−18
compare with master
unifiedsplit
@@ -1,8 +1,12 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Dups
3module Canonicalize.Environment.Dups
4− ( Info(Info)
4+ ( Dict
5− , info
5+ , none
6+ , one
7+ , union
8+ , unions
9+ , insert
6 , detect
10 , detect
7 , checkFields
11 , checkFields
8 )
12 )
@@ -12,6 +16,7 @@ module Canonicalize.Environment.Dups
12import qualified Data.Map as Map
16import qualified Data.Map as Map
13
17
14import Canonicalize.Environment.Internals (Result)
18import Canonicalize.Environment.Internals (Result)
19+import qualified Data.OneOrMore as OneOrMore
15import qualified Elm.Name as N
20import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
@@ -23,6 +28,10 @@ import qualified Reporting.Result as Result
23-- INFO
28-- INFO
24
29
25
30
31+type Dict category value =
32+ Map.Map N.Name (OneOrMore.OneOrMore (Info category value))
33+
34+
26data Info category value =
35data Info category value =
27 Info
36 Info
28 { _region :: R.Region
37 { _region :: R.Region
@@ -31,10 +40,29 @@ data Info category value =
31 }
40 }
32
41
33
42
34−{-# INLINE info #-}
43+none :: Dict c v
44+none =
45+ Map.empty
46+
47+
35−info :: N.Name -> R.Region -> category -> value -> ( N.Name, [Info category value] )
48+one :: N.Name -> R.Region -> category -> value -> Dict category value
49+one name region category value =
50+ Map.singleton name (OneOrMore.one (Info region category value))
51+
52+
53+union :: Dict c v -> Dict c v -> Dict c v
54+union a b =
55+ Map.unionWith OneOrMore.more a b
56+
57+
58+unions :: [Dict c v] -> Dict c v
59+unions dicts =
60+ Map.unionsWith OneOrMore.more dicts
61+
62+
63+insert :: N.Name -> R.Region -> c -> v -> Dict c v -> Dict c v
36−info name region category value =
64+insert name region category value dict =
37− ( name, [Info region category value] )
65+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region category value)) dict
38
66
39
67
40
68
@@ -45,22 +73,23 @@ type ToError c =
45 N.Name -> c -> c -> Error.Error
73 N.Name -> c -> c -> Error.Error
46
74
47
75
48−detect :: ToError c -> [(N.Name, [Info c v])] -> Result () (Map.Map N.Name v)
76+detect :: ToError c -> Dict c v -> Result () (Map.Map N.Name v)
49−detect toError pairs =
77+detect toError dict =
50− Map.traverseWithKey (detectHelp toError) $ Map.fromListWith (++) pairs
78+ Map.traverseWithKey (detectHelp toError) dict
51
79
52
80
53−detectHelp :: ToError c -> N.Name -> [Info c v] -> Result () v
81+detectHelp :: ToError c -> N.Name -> OneOrMore.OneOrMore (Info c v) -> Result () v
54detectHelp toError name values =
82detectHelp toError name values =
55 case values of
83 case values of
56− [Info _ _ value] ->
84+ OneOrMore.One (Info _ _ value) ->
57 Result.ok value
85 Result.ok value
58
86
59− [] ->
87+ OneOrMore.More _ _ ->
60− error "impossible: use a non-empty data structure to rule this out"
88+ let
61−
89+ (Info r1 c1 _ : Info r2 c2 _ : _) =
62− Info region1 category1 _ : Info region2 category2 _ : _ ->
90+ OneOrMore.toList values
91+ in
63− Result.throw (max region1 region2) (toError name category1 category2)
92+ Result.throw (max r1 r2) (toError name c1 c2)
64
93
65
94
66
95
@@ -71,9 +100,10 @@ checkFields :: [(A.Located N.Name, a)] -> Result () (Map.Map N.Name a)
71checkFields fields =
100checkFields fields =
72 let
101 let
73 toInfo (A.A region name, value) =
102 toInfo (A.A region name, value) =
74− info name region () value
103+ Map.singleton name (OneOrMore.one (Info region () value))
75
104
76 toError name () () =
105 toError name () () =
77 Error.DuplicateField name
106 Error.DuplicateField name
78 in
107 in
79− detect toError $ map toInfo fields
108+ detect toError $
109+ Map.unionsWith OneOrMore.more (map toInfo fields)
src/Canonicalize/Environment/Local.hs+38−37
@@ -135,59 +135,58 @@ addVarsHelp localVars vars =
135collectLowerVars :: Valid.Module -> Result (Map.Map N.Name ())
135collectLowerVars :: Valid.Module -> Result (Map.Map N.Name ())
136collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
136collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
137 let
137 let
138− declToInfo (A.A _ (Valid.Decl (A.A region name) _ _ _)) =
138+ addDecl (A.A _ (Valid.Decl (A.A region name) _ _ _)) dict =
139− Dups.info name region () ()
139+ Dups.insert name region () () dict
140
140
141− portToInfo (Valid.Port (A.A region name) _) =
141+ addPort (Valid.Port (A.A region name) _) dict =
142− Dups.info name region () ()
142+ Dups.insert name region () () dict
143
143
144− effectInfo =
144+ effectDict =
145 case effects of
145 case effects of
146 Valid.NoEffects ->
146 Valid.NoEffects ->
147− []
147+ Dups.none
148
148
149 Valid.Ports ports ->
149 Valid.Ports ports ->
150− map portToInfo ports
150+ foldr addPort Dups.none ports
151
151
152 Valid.Manager _ manager ->
152 Valid.Manager _ manager ->
153 case manager of
153 case manager of
154 Valid.Cmd (A.A region _) ->
154 Valid.Cmd (A.A region _) ->
155− [ Dups.info "command" region () () ]
155+ Dups.one "command" region () ()
156
156
157 Valid.Sub (A.A region _) ->
157 Valid.Sub (A.A region _) ->
158− [ Dups.info "subscription" region () () ]
158+ Dups.one "subscription" region () ()
159
159
160 Valid.Fx (A.A regionCmd _) (A.A regionSub _) ->
160 Valid.Fx (A.A regionCmd _) (A.A regionSub _) ->
161+ Dups.union
161− [ Dups.info "command" regionCmd () ()
162+ (Dups.one "command" regionCmd () ())
162− , Dups.info "subscription" regionSub () ()
163+ (Dups.one "subscription" regionSub () ())
163− ]
164
164
165 toError name () () =
165 toError name () () =
166 Error.DuplicateDecl name
166 Error.DuplicateDecl name
167 in
167 in
168− Dups.detect toError $
168+ Dups.detect toError $ foldr addDecl effectDict decls
169− effectInfo ++ map declToInfo decls
170
169
171
170
172collectUpperVars :: Valid.Module -> Result (Map.Map N.Name ())
171collectUpperVars :: Valid.Module -> Result (Map.Map N.Name ())
173collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
172collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
174 let
173 let
175− unionToInfos (Valid.Union (A.A _ name) _ ctors) =
174+ addUnion (Valid.Union (A.A _ name) _ ctors) dict =
176− map (ctorToInfo name) ctors
175+ foldr (addCtor name) dict ctors
177
176
178− ctorToInfo tipe (A.A region name, _args) =
177+ addCtor tipe (A.A region name, _args) dict =
179− Dups.info name region (Error.UnionCtor tipe) ()
178+ Dups.insert name region (Error.UnionCtor tipe) () dict
180
179
181− aliasToInfos (Valid.Alias (A.A region name) _ (A.A _ tipe)) =
180+ addAlias (Valid.Alias (A.A region name) _ (A.A _ tipe)) dict =
182 case tipe of
181 case tipe of
183 Src.TRecord _ Nothing ->
182 Src.TRecord _ Nothing ->
184− [ Dups.info name region Error.RecordCtor () ]
183+ Dups.insert name region Error.RecordCtor () dict
185
184
186 _ ->
185 _ ->
187− []
186+ dict
188 in
187 in
189 Dups.detect Error.DuplicateCtor $
188 Dups.detect Error.DuplicateCtor $
190− concatMap aliasToInfos aliases ++ concatMap unionToInfos unions
189+ foldr addAlias (foldr addUnion Dups.none unions) aliases
191
190
192
191
193
192
@@ -197,23 +196,25 @@ collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
197addTypes :: Valid.Module -> Env.Env -> Result Env.Env
196addTypes :: Valid.Module -> Env.Env -> Result Env.Env
198addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
197addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
199 let
198 let
200− aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =
199+ aliasToDict alias@(Valid.Alias (A.A region name) _ tipe) =
201 do args <- checkAliasFreeVars alias
200 do args <- checkAliasFreeVars alias
202− return $ Dups.info name region () (Left (Alias region name args tipe))
201+ return $ Dups.one name region () (Left (Alias region name args tipe))
203
202
204− unionToInfo union@(Valid.Union (A.A region name) _ _) =
203+ unionToDict union@(Valid.Union (A.A region name) _ _) =
205 do arity <- checkUnionFreeVars union
204 do arity <- checkUnionFreeVars union
206− return $ Dups.info name region () (Right arity)
205+ return $ Dups.one name region () (Right arity)
207
206
208 toError name () () =
207 toError name () () =
209 Error.DuplicateType name
208 Error.DuplicateType name
210
209
211− infos =
210+ combineDicts dicts1 dicts2 =
212− liftA2 (++)
211+ Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
213− (traverse aliasToInfo aliases)
214− (traverse unionToInfo unions)
215 in
212 in
213+ do dict <-
214+ liftA2 combineDicts
215+ (traverse aliasToDict aliases)
216+ (traverse unionToDict unions)
216− do types <- Dups.detect toError =<< infos
217+ types <- Dups.detect toError dict
217 let (aliasDict, unionDict) = Map.mapEither id types
218 let (aliasDict, unionDict) = Map.mapEither id types
218 addTypeAliases aliasDict (addUnionTypes unionDict env)
219 addTypeAliases aliasDict (addUnionTypes unionDict env)
219
220
@@ -326,8 +327,8 @@ getEdges (A.A _ tipe) =
326checkUnionFreeVars :: Valid.Union -> Result Int
327checkUnionFreeVars :: Valid.Union -> Result Int
327checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
328checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
328 let
329 let
329− toInfo (A.A region arg) =
330+ addUnion (A.A region arg) dict =
330− Dups.info arg region () region
331+ Dups.insert arg region () region dict
331
332
332 toError badArg () () =
333 toError badArg () () =
333 Error.DuplicateUnionArg name badArg (map A.drop args)
334 Error.DuplicateUnionArg name badArg (map A.drop args)
@@ -335,7 +336,7 @@ checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
335 addCtorFreeVars (_, tipes) freeVars =
336 addCtorFreeVars (_, tipes) freeVars =
336 foldr addFreeVars freeVars tipes
337 foldr addFreeVars freeVars tipes
337 in
338 in
338− do boundVars <- Dups.detect toError (map toInfo args)
339+ do boundVars <- Dups.detect toError (foldr addUnion Dups.none args)
339 let freeVars = foldr addCtorFreeVars Map.empty ctors
340 let freeVars = foldr addCtorFreeVars Map.empty ctors
340 case Map.toList (Map.difference freeVars boundVars) of
341 case Map.toList (Map.difference freeVars boundVars) of
341 [] ->
342 [] ->
@@ -351,13 +352,13 @@ checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
351checkAliasFreeVars :: Valid.Alias -> Result [N.Name]
352checkAliasFreeVars :: Valid.Alias -> Result [N.Name]
352checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =
353checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =
353 let
354 let
354− toInfo (A.A region arg) =
355+ addAlias (A.A region arg) dict =
355− Dups.info arg region () region
356+ Dups.insert arg region () region dict
356
357
357 toError badArg () () =
358 toError badArg () () =
358 Error.DuplicateAliasArg name badArg (map A.drop args)
359 Error.DuplicateAliasArg name badArg (map A.drop args)
359 in
360 in
360− do boundVars <- Dups.detect toError (map toInfo args)
361+ do boundVars <- Dups.detect toError (foldr addAlias Dups.none args)
361 let freeVars = addFreeVars tipe Map.empty
362 let freeVars = addFreeVars tipe Map.empty
362 let overlap = Map.size (Map.intersection boundVars freeVars)
363 let overlap = Map.size (Map.intersection boundVars freeVars)
363 if Map.size boundVars == overlap && Map.size freeVars == overlap
364 if Map.size boundVars == overlap && Map.size freeVars == overlap
src/Canonicalize/Expression.hs+25−25
@@ -272,8 +272,8 @@ canonicalizeLet letRegion env defs body =
272 addLocals $
272 addLocals $
273 do let keyedDefs = zip defs [ 0 .. length defs ]
273 do let keyedDefs = zip defs [ 0 .. length defs ]
274 let toError name () () = Error.DuplicatePattern Error.DPLetBinding name
274 let toError name () () = Error.DuplicatePattern Error.DPLetBinding name
275− let namesBag = foldr addBindings Bag.empty keyedDefs
275+ let names = foldr addBindings Dups.none keyedDefs
276− boundNames <- Dups.detect toError (Bag.toList namesBag)
276+ boundNames <- Dups.detect toError names
277 newEnv <- Env.addLocals boundNames env
277 newEnv <- Env.addLocals boundNames env
278 let defKeys = Map.map A.drop boundNames
278 let defKeys = Map.map A.drop boundNames
279 nodes <- traverse (defToNode defKeys newEnv) keyedDefs
279 nodes <- traverse (defToNode defKeys newEnv) keyedDefs
@@ -324,62 +324,62 @@ toUnusedWarning unused (name, A.A region _) =
324-- ADD BINDINGS
324-- ADD BINDINGS
325
325
326
326
327−type KeyBag =
327+type Bindings =
328− Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
328+ Dups.Dict () (A.Located Int)
329
329
330
330
331−addBindings :: (Valid.Def, Int) -> KeyBag -> KeyBag
331+addBindings :: (Valid.Def, Int) -> Bindings -> Bindings
332−addBindings (def, key) bag =
332+addBindings (def, key) bindings =
333 case def of
333 case def of
334 Valid.Define defRegion (A.A region name) _ _ _ ->
334 Valid.Define defRegion (A.A region name) _ _ _ ->
335− Bag.insert (Dups.info name region () (A.A defRegion key)) bag
335+ Dups.insert name region () (A.A defRegion key) bindings
336
336
337 Valid.Destruct defRegion pattern _ ->
337 Valid.Destruct defRegion pattern _ ->
338− addBindingsHelp (A.A defRegion key) pattern bag
338+ addBindingsHelp (A.A defRegion key) pattern bindings
339
339
340
340
341−addBindingsHelp :: A.Located Int -> Src.Pattern -> KeyBag -> KeyBag
341+addBindingsHelp :: A.Located Int -> Src.Pattern -> Bindings -> Bindings
342−addBindingsHelp key (A.A region pattern) bag =
342+addBindingsHelp key (A.A region pattern) bindings =
343 case pattern of
343 case pattern of
344 Src.PAnything ->
344 Src.PAnything ->
345− bag
345+ bindings
346
346
347 Src.PVar name ->
347 Src.PVar name ->
348− Bag.insert (Dups.info name region () key) bag
348+ Dups.insert name region () key bindings
349
349
350 Src.PRecord fields ->
350 Src.PRecord fields ->
351 let
351 let
352− fieldToInfo (A.A fieldRegion name) =
352+ addField (A.A fieldRegion name) dict =
353− Dups.info name fieldRegion () key
353+ Dups.insert name fieldRegion () key dict
354 in
354 in
355− foldr (\f b -> Bag.insert (fieldToInfo f) b) bag fields
355+ foldr addField bindings fields
356
356
357 Src.PUnit ->
357 Src.PUnit ->
358− bag
358+ bindings
359
359
360 Src.PTuple a b cs ->
360 Src.PTuple a b cs ->
361− foldr (addBindingsHelp key) bag (a:b:cs)
361+ foldr (addBindingsHelp key) bindings (a:b:cs)
362
362
363 Src.PCtor _ _ _ patterns ->
363 Src.PCtor _ _ _ patterns ->
364− foldr (addBindingsHelp key) bag patterns
364+ foldr (addBindingsHelp key) bindings patterns
365
365
366 Src.PList patterns ->
366 Src.PList patterns ->
367− foldr (addBindingsHelp key) bag patterns
367+ foldr (addBindingsHelp key) bindings patterns
368
368
369 Src.PCons first rest ->
369 Src.PCons first rest ->
370− addBindingsHelp key rest (addBindingsHelp key first bag)
370+ addBindingsHelp key rest (addBindingsHelp key first bindings)
371
371
372 Src.PAlias ptrn (A.A reg name) ->
372 Src.PAlias ptrn (A.A reg name) ->
373− addBindingsHelp key ptrn (Bag.insert (Dups.info name reg () key) bag)
373+ addBindingsHelp key ptrn (Dups.insert name reg () key bindings)
374
374
375 Src.PChr _ ->
375 Src.PChr _ ->
376− bag
376+ bindings
377
377
378 Src.PStr _ ->
378 Src.PStr _ ->
379− bag
379+ bindings
380
380
381 Src.PInt _ ->
381 Src.PInt _ ->
382− bag
382+ bindings
383
383
384
384
385
385
@@ -450,7 +450,7 @@ toNode defKeys key args (Result.Result freeLocals warnings answer) =
450-- GATHER TYPED ARGS
450-- GATHER TYPED ARGS
451
451
452
452
453−gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bag ([Can.TypedArg], Can.Type)
453+gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bindings ([Can.TypedArg], Can.Type)
454gatherTypedArgs env name srcArgs tipe index revTypedArgs =
454gatherTypedArgs env name srcArgs tipe index revTypedArgs =
455 case srcArgs of
455 case srcArgs of
456 [] ->
456 [] ->
src/Canonicalize/Module.hs+8−8
@@ -237,7 +237,7 @@ canonicalizeExports decls unions aliases binops effects exposing =
237 do let names = Map.fromList (map declToName decls)
237 do let names = Map.fromList (map declToName decls)
238 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
238 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
239 let toError name () () = Error.ExportDuplicate name
239 let toError name () () = Error.ExportDuplicate name
240− Can.Export <$> Dups.detect toError infos
240+ Can.Export <$> Dups.detect toError (Dups.unions infos)
241
241
242
242
243declToName :: A.Located Valid.Decl -> ( N.Name, () )
243declToName :: A.Located Valid.Decl -> ( N.Name, () )
@@ -252,16 +252,16 @@ checkExposed
252 -> Map.Map N.Name binop
252 -> Map.Map N.Name binop
253 -> Can.Effects
253 -> Can.Effects
254 -> A.Located Src.Exposed
254 -> A.Located Src.Exposed
255− -> Result (N.Name, [Dups.Info () Can.Export])
255+ -> Result (Dups.Dict () Can.Export)
256checkExposed decls unions aliases binops effects (A.A region exposed) =
256checkExposed decls unions aliases binops effects (A.A region exposed) =
257 case exposed of
257 case exposed of
258 Src.Lower name ->
258 Src.Lower name ->
259 if Map.member name decls then
259 if Map.member name decls then
260− Result.ok (Dups.info name region () Can.ExportValue)
260+ Result.ok (Dups.one name region () Can.ExportValue)
261 else
261 else
262 case checkPorts effects name of
262 case checkPorts effects name of
263 Nothing ->
263 Nothing ->
264− Result.ok (Dups.info name region () Can.ExportPort)
264+ Result.ok (Dups.one name region () Can.ExportPort)
265
265
266 Just ports ->
266 Just ports ->
267 Result.throw region $ Error.ExportNotFound Error.BadVar name $
267 Result.throw region $ Error.ExportNotFound Error.BadVar name $
@@ -269,14 +269,14 @@ checkExposed decls unions aliases binops effects (A.A region exposed) =
269
269
270 Src.Operator name ->
270 Src.Operator name ->
271 if Map.member name binops then
271 if Map.member name binops then
272− Result.ok (Dups.info name region () Can.ExportBinop)
272+ Result.ok (Dups.one name region () Can.ExportBinop)
273 else
273 else
274 Result.throw region $ Error.ExportNotFound Error.BadOp name $
274 Result.throw region $ Error.ExportNotFound Error.BadOp name $
275 Map.keys binops
275 Map.keys binops
276
276
277 Src.Upper name Src.Public ->
277 Src.Upper name Src.Public ->
278 if Map.member name unions then
278 if Map.member name unions then
279− Result.ok (Dups.info name region () Can.ExportUnionOpen)
279+ Result.ok (Dups.one name region () Can.ExportUnionOpen)
280 else if Map.member name aliases then
280 else if Map.member name aliases then
281 Result.throw region $ Error.ExportOpenAlias name
281 Result.throw region $ Error.ExportOpenAlias name
282 else
282 else
@@ -285,9 +285,9 @@ checkExposed decls unions aliases binops effects (A.A region exposed) =
285
285
286 Src.Upper name Src.Private ->
286 Src.Upper name Src.Private ->
287 if Map.member name unions then
287 if Map.member name unions then
288− Result.ok (Dups.info name region () Can.ExportUnionClosed)
288+ Result.ok (Dups.one name region () Can.ExportUnionClosed)
289 else if Map.member name aliases then
289 else if Map.member name aliases then
290− Result.ok (Dups.info name region () Can.ExportAlias)
290+ Result.ok (Dups.one name region () Can.ExportAlias)
291 else
291 else
292 Result.throw region $ Error.ExportNotFound Error.BadType name $
292 Result.throw region $ Error.ExportNotFound Error.BadType name $
293 Map.keys unions ++ Map.keys aliases
293 Map.keys unions ++ Map.keys aliases
src/Canonicalize/Pattern.hs+18−19
@@ -1,7 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
2module Canonicalize.Pattern
3 ( verify
3 ( verify
4− , Bag
4+ , Bindings
5 , canonicalize
5 , canonicalize
6 , canonicalizeArg
6 , canonicalizeArg
7 )
7 )
@@ -12,9 +12,7 @@ import qualified AST.Canonical as Can
12import qualified AST.Source as Src
12import qualified AST.Source as Src
13import qualified Canonicalize.Environment as Env
13import qualified Canonicalize.Environment as Env
14import qualified Canonicalize.Environment.Dups as Dups
14import qualified Canonicalize.Environment.Dups as Dups
15−import qualified Data.Bag as Bag
16import qualified Data.Index as Index
15import qualified Data.Index as Index
17−import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
17import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Region as R
18import qualified Reporting.Region as R
@@ -34,12 +32,12 @@ type Result i =
34-- VERIFY NAMES
32-- VERIFY NAMES
35
33
36
34
37−verify :: Error.DuplicatePatternContext -> Result Bag a -> Result () (a, Can.Destructors)
35+verify :: Error.DuplicatePatternContext -> Result Bindings a -> Result () (a, Can.Destructors)
38−verify context (Result.Result bag warnings answer) =
36+verify context (Result.Result bindings warnings answer) =
39 case answer of
37 case answer of
40 Result.Ok value ->
38 Result.Ok value ->
41 do let toError name () () = Error.DuplicatePattern context name
39 do let toError name () () = Error.DuplicatePattern context name
42− destructors <- Dups.detect toError (Bag.toList bag)
40+ destructors <- Dups.detect toError bindings
43 Result.Result () warnings $ Result.Ok (value, destructors)
41 Result.Result () warnings $ Result.Ok (value, destructors)
44
42
45 Result.Err err ->
43 Result.Err err ->
@@ -50,7 +48,7 @@ verify context (Result.Result bag warnings answer) =
50-- CANONICALIZE ARG
48-- CANONICALIZE ARG
51
49
52
50
53−canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
51+canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Arg
54canonicalizeArg env index pattern =
52canonicalizeArg env index pattern =
55 Can.Arg index <$> canonicalize env index pattern
53 Can.Arg index <$> canonicalize env index pattern
56
54
@@ -59,16 +57,16 @@ canonicalizeArg env index pattern =
59-- CANONICALIZE
57-- CANONICALIZE
60
58
61
59
62−type Bag =
60+type Bindings =
63− Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
61+ Dups.Dict () (A.Located Can.Destructor)
64
62
65
63
66−canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Pattern
64+canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Pattern
67canonicalize env index pattern =
65canonicalize env index pattern =
68 process env (Can.DRoot index) pattern
66 process env (Can.DRoot index) pattern
69
67
70
68
71−process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
69+process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bindings Can.Pattern
72process env destructor (A.A region pattern) =
70process env destructor (A.A region pattern) =
73 A.A region <$>
71 A.A region <$>
74 case pattern of
72 case pattern of
@@ -77,16 +75,16 @@ process env destructor (A.A region pattern) =
77
75
78 Src.PVar name ->
76 Src.PVar name ->
79 Result.accumulate
77 Result.accumulate
80− (Bag.one (Dups.info name region () (A.A region destructor)))
78+ (Dups.one name region () (A.A region destructor))
81 (Can.PVar name)
79 (Can.PVar name)
82
80
83 Src.PRecord fields ->
81 Src.PRecord fields ->
84 let
82 let
85− fieldToInfo (A.A reg name) =
83+ addField (A.A reg name) dict =
86− Dups.info name reg () (A.A reg (Can.DField name destructor))
84+ Dups.insert name reg () (A.A reg (Can.DField name destructor)) dict
87 in
85 in
88 Result.accumulate
86 Result.accumulate
89− (Bag.fromList fieldToInfo fields)
87+ (foldr addField Dups.none fields)
90 (Can.PRecord (map A.drop fields))
88 (Can.PRecord (map A.drop fields))
91
89
92 Src.PUnit ->
90 Src.PUnit ->
@@ -123,8 +121,9 @@ process env destructor (A.A region pattern) =
123
121
124 Src.PAlias ptrn (A.A reg name) ->
122 Src.PAlias ptrn (A.A reg name) ->
125 do cpattern <- process env destructor ptrn
123 do cpattern <- process env destructor ptrn
126− let info = Dups.info name reg () (A.A reg destructor)
124+ Result.accumulate
125+ (Dups.one name reg () (A.A reg destructor))
127− Result.accumulate (Bag.one info) (Can.PAlias cpattern name)
126+ (Can.PAlias cpattern name)
128
127
129 Src.PChr chr ->
128 Src.PChr chr ->
130 Result.ok (Can.PChr chr)
129 Result.ok (Can.PChr chr)
@@ -136,7 +135,7 @@ process env destructor (A.A region pattern) =
136 Result.ok (Can.PInt int)
135 Result.ok (Can.PInt int)
137
136
138
137
139−processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)
138+processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings (Maybe Can.Pattern)
140processTuple tupleRegion env destructor extras =
139processTuple tupleRegion env destructor extras =
141 case extras of
140 case extras of
142 [] ->
141 [] ->
@@ -150,7 +149,7 @@ processTuple tupleRegion env destructor extras =
150 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
149 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
151
150
152
151
153−processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]
152+processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings [Can.Pattern]
154processList env destructor list =
153processList env destructor list =
155 case list of
154 case list of
156 [] ->
155 [] ->