git.iko.soy/elk
on master help sign in
Shuffle canonicalization code to simplify type constraint generation
a964796Evan Czaplicki
src/AST/Canonical.hs+17−23
compare with master
unifiedsplit
@@ -4,7 +4,8 @@ module AST.Canonical
4 ( Expr, Expr_(..)
4 ( Expr, Expr_(..)
5 , CaseBranch(..)
5 , CaseBranch(..)
6 , Def(..)
6 , Def(..)
7− , Args(..), Arg(..)
7+ , Arg(..)
8+ , TypedArg(..)
8 -- patterns
9 -- patterns
9 , Pattern, Pattern_(..)
10 , Pattern, Pattern_(..)
10 , PatternCtorArg(..)
11 , PatternCtorArg(..)
@@ -16,7 +17,6 @@ module AST.Canonical
16 , AliasType(..)
17 , AliasType(..)
17 -- decls
18 -- decls
18 , Decls(..)
19 , Decls(..)
19− , Decl(..)
20 , Module(..)
20 , Module(..)
21 , Alias(..)
21 , Alias(..)
22 , Union(..)
22 , Union(..)
@@ -67,7 +67,7 @@ data Expr_
67 | List [Expr]
67 | List [Expr]
68 | Negate Expr
68 | Negate Expr
69 | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr
69 | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr
70− | Lambda Args Expr
70+ | Lambda [Arg] Destructors Expr
71 | Call Expr [Expr]
71 | Call Expr [Expr]
72 | If [(Expr, Expr)] Expr
72 | If [(Expr, Expr)] Expr
73 | Let Def Expr
73 | Let Def Expr
@@ -84,30 +84,26 @@ data Expr_
84
84
85
85
86data CaseBranch =
86data CaseBranch =
87− CaseBranch
87+ CaseBranch Pattern Destructors Expr
88− { _branch_index :: Index.ZeroBased
89− , _branch_pattern :: Pattern
90− , _branch_destructors :: Destructors
91− , _branch_expr :: Expr
92− }
93
88
94
89
95
90
96-- DEFS
91-- DEFS
97
92
98
93
99−data Def =
94+data Def
100− Def (A.Located N.Name) Args Expr (Maybe Annotation)
101−
102−
103−data Args =
104− Args [Arg] Destructors
95+ = Def (A.Located N.Name) [Arg] Destructors Expr
96+ | TypedDef (A.Located N.Name) FreeVars [TypedArg] Destructors Expr Type
105
97
106
98
107data Arg =
99data Arg =
108 Arg Index.ZeroBased Pattern
100 Arg Index.ZeroBased Pattern
109
101
110
102
103+data TypedArg =
104+ TypedArg Index.ZeroBased Type Pattern
105+
106+
111
107
112-- PATTERNS
108-- PATTERNS
113
109
@@ -155,7 +151,10 @@ data Destructor
155-- TYPES
151-- TYPES
156
152
157
153
158−data Annotation = Forall (Map.Map N.Name ()) Type
154+data Annotation = Forall FreeVars Type
155+
156+
157+type FreeVars = Map.Map N.Name ()
159
158
160
159
161data Type
160data Type
@@ -178,16 +177,11 @@ data AliasType
178
177
179
178
180data Decls
179data Decls
181− = Declare Decl Decls
180+ = Declare Def Decls
182− | DeclareRec Decl [Decl] Decls
181+ | DeclareRec Def [Def] Decls
183 | SaveTheEnvironment
182 | SaveTheEnvironment
184
183
185
184
186−data Decl
187− = Value N.Name Expr (Maybe Annotation)
188− | Function N.Name Args Expr (Maybe Annotation)
189−
190−
191
185
192-- MODULES
186-- MODULES
193
187
src/Canonicalize/Expression.hs+163−54
@@ -2,6 +2,7 @@
2module Canonicalize.Expression
2module Canonicalize.Expression
3 ( canonicalize
3 ( canonicalize
4 , removeLocals
4 , removeLocals
5+ , gatherTypedArgs
5 )
6 )
6 where
7 where
7
8
@@ -10,9 +11,10 @@ import qualified Data.Graph as Graph
10import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
11import qualified Data.Set as Set
12import qualified Data.Set as Set
12
13
13−import qualified AST.Utils.Binop as Binop
14import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
15import qualified AST.Source as Src
15import qualified AST.Source as Src
16+import qualified AST.Utils.Binop as Binop
17+import qualified AST.Utils.Type as Type
16import qualified AST.Valid as Valid
18import qualified AST.Valid as Valid
17import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Environment.Dups as Dups
@@ -76,12 +78,14 @@ canonicalize env (A.A region expression) =
76 Valid.Binops ops final ->
78 Valid.Binops ops final ->
77 A.drop <$> canonicalizeBinops region env ops final
79 A.drop <$> canonicalizeBinops region env ops final
78
80
79− Valid.Lambda args body ->
81+ Valid.Lambda srcArgs body ->
80 addLocals $
82 addLocals $
81− do cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
83+ do (args, destructors) <-
84+ Pattern.verify Error.DPLambdaArgs $
85+ Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
82 newEnv <- Env.addLocals destructors env
86 newEnv <- Env.addLocals destructors env
83 removeLocals Warning.Pattern destructors $
87 removeLocals Warning.Pattern destructors $
84− Can.Lambda cargs <$> canonicalize newEnv body
88+ Can.Lambda args destructors <$> canonicalize newEnv body
85
89
86 Valid.Call func args ->
90 Valid.Call func args ->
87 Can.Call
91 Can.Call
@@ -99,7 +103,7 @@ canonicalize env (A.A region expression) =
99 Valid.Case expr branches ->
103 Valid.Case expr branches ->
100 Can.Case
104 Can.Case
101 <$> canonicalize env expr
105 <$> canonicalize env expr
102− <*> Index.indexedTraverse (canonicalizeCaseBranch env) branches
106+ <*> traverse (canonicalizeCaseBranch env) branches
103
107
104 Valid.Accessor field ->
108 Valid.Accessor field ->
105 Result.ok $ Can.Accessor field
109 Result.ok $ Can.Accessor field
@@ -165,13 +169,15 @@ canonicalizeIfBranch env (condition, branch) =
165-- CANONICALIZE CASE BRANCH
169-- CANONICALIZE CASE BRANCH
166
170
167
171
168−canonicalizeCaseBranch :: Env.Env -> Index.ZeroBased -> (Src.Pattern, Valid.Expr) -> Result FreeLocals Can.CaseBranch
172+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals Can.CaseBranch
169−canonicalizeCaseBranch env index (pattern, expr) =
173+canonicalizeCaseBranch env (pattern, expr) =
170 addLocals $
174 addLocals $
175+ do (cpattern, destructors) <-
176+ Pattern.verify Error.DPCaseBranch $
171− do (cpattern, destructors) <- Pattern.canonicalize env index pattern
177+ Pattern.canonicalize env Index.first pattern
172 newEnv <- Env.addLocals destructors env
178 newEnv <- Env.addLocals destructors env
173 removeLocals Warning.Pattern destructors $
179 removeLocals Warning.Pattern destructors $
174− Can.CaseBranch index cpattern destructors <$> canonicalize newEnv expr
180+ Can.CaseBranch cpattern destructors <$> canonicalize newEnv expr
175
181
176
182
177
183
@@ -262,15 +268,18 @@ toBinop (Env.Binop op home name annotation _ _) left right =
262
268
263
269
264canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals Can.Expr
270canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals Can.Expr
265−canonicalizeLet region env defs body =
271+canonicalizeLet letRegion env defs body =
266 addLocals $
272 addLocals $
267− do (bindings, boundNames) <- Pattern.canonicalizeBindings env defs
273+ do let keyedDefs = zip defs [ 0 .. length defs ]
274+ let toError name () () = Error.DuplicatePattern Error.DPLetBinding name
275+ let namesBag = foldr addBindings Bag.empty keyedDefs
276+ boundNames <- Dups.detect toError (Bag.toList namesBag)
268 newEnv <- Env.addLocals boundNames env
277 newEnv <- Env.addLocals boundNames env
269 let defKeys = Map.map A.drop boundNames
278 let defKeys = Map.map A.drop boundNames
270− nodes <- Result.untracked $ traverse (bindingToNode defKeys newEnv) bindings
279+ nodes <- traverse (defToNode defKeys newEnv) keyedDefs
271 removeLocals Warning.Binding boundNames $
280 removeLocals Warning.Binding boundNames $
272 do cbody <- canonicalize env body
281 do cbody <- canonicalize env body
273− detectCycles region (Graph.stronglyConnComp nodes) cbody
282+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
274
283
275
284
276addLocals :: Result () (expr, FreeLocals) -> Result FreeLocals expr
285addLocals :: Result () (expr, FreeLocals) -> Result FreeLocals expr
@@ -312,35 +321,114 @@ toUnusedWarning unused (name, A.A region _) =
312
321
313
322
314
323
324+-- ADD BINDINGS
325+
326+
327+type KeyBag =
328+ Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
329+
330+
331+addBindings :: (Valid.Def, Int) -> KeyBag -> KeyBag
332+addBindings (def, key) bag =
333+ case def of
334+ Valid.Define defRegion (A.A region name) _ _ _ ->
335+ Bag.insert (Dups.info name region () (A.A defRegion key)) bag
336+
337+ Valid.Destruct defRegion pattern _ ->
338+ addBindingsHelp (A.A defRegion key) pattern bag
339+
340+
341+addBindingsHelp :: A.Located Int -> Src.Pattern -> KeyBag -> KeyBag
342+addBindingsHelp key (A.A region pattern) bag =
343+ case pattern of
344+ Src.PAnything ->
345+ bag
346+
347+ Src.PVar name ->
348+ Bag.insert (Dups.info name region () key) bag
349+
350+ Src.PRecord fields ->
351+ let
352+ fieldToInfo (A.A fieldRegion name) =
353+ Dups.info name fieldRegion () key
354+ in
355+ foldr (\f b -> Bag.insert (fieldToInfo f) b) bag fields
356+
357+ Src.PUnit ->
358+ bag
359+
360+ Src.PTuple a b cs ->
361+ foldr (addBindingsHelp key) bag (a:b:cs)
362+
363+ Src.PCtor _ _ _ patterns ->
364+ foldr (addBindingsHelp key) bag patterns
365+
366+ Src.PList patterns ->
367+ foldr (addBindingsHelp key) bag patterns
368+
369+ Src.PCons first rest ->
370+ addBindingsHelp key rest (addBindingsHelp key first bag)
371+
372+ Src.PAlias ptrn (A.A reg name) ->
373+ addBindingsHelp key ptrn (Bag.insert (Dups.info name reg () key) bag)
374+
375+ Src.PChr _ ->
376+ bag
377+
378+ Src.PStr _ ->
379+ bag
380+
381+ Src.PInt _ ->
382+ bag
383+
384+
385+
315-- BUILD BINDINGS GRAPH
386-- BUILD BINDINGS GRAPH
316
387
317
388
389+data Node = Node Binding FreeLocals
390+
391+
318data Binding
392data Binding
319 = Define R.Region Can.Def
393 = Define R.Region Can.Def
320 | Destruct R.Region Can.Pattern Can.Destructors Can.Expr
394 | Destruct R.Region Can.Pattern Can.Destructors Can.Expr
321
395
322
396
323−data Node = Node Binding FreeLocals
324−
325−
326−bindingToNode :: Map.Map N.Name Int -> Env.Env -> Pattern.Binding -> Result () (Node, Int, [Int])
397+defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result () (Node, Int, [Int])
327−bindingToNode defKeys env binding =
398+defToNode defKeys env (def, key) =
328− case binding of
399+ case def of
329− Pattern.Define region index name args body maybeType ->
400+ Valid.Define region aname@(A.A _ name) srcArgs body Nothing ->
330− do cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
401+ do (args, destructors) <-
331− maybeAnnotation <- traverse (Type.toAnnotation env) maybeType
402+ Pattern.verify (Error.DPFuncArgs name) $
403+ Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
332 newEnv <- Env.addLocals destructors env
404 newEnv <- Env.addLocals destructors env
333− toNode defKeys destructors index $
405+ toNode defKeys key destructors $
334 do cbody <- canonicalize newEnv body
406 do cbody <- canonicalize newEnv body
335− return $ Define region $ Can.Def name cargs cbody maybeAnnotation
407+ return $ Define region $
336−
408+ Can.Def aname args destructors cbody
409+
337− Pattern.Destruct region index pattern destructors body ->
410+ Valid.Destruct region pattern body ->
411+ do (cpattern, destructors) <-
412+ Pattern.verify Error.DPDestruct $
413+ Pattern.canonicalize env Index.first pattern
414+
338− toNode defKeys Map.empty index $
415+ toNode defKeys key destructors $
339− Destruct region pattern destructors <$> canonicalize env body
416+ Destruct region cpattern destructors <$> canonicalize env body
417+
418+ Valid.Define region aname@(A.A _ name) srcArgs body (Just tipe) ->
419+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
420+ ((args, resultType), destructors) <-
421+ Pattern.verify (Error.DPFuncArgs name) $
422+ gatherTypedArgs env name srcArgs ctipe Index.first []
423+ newEnv <- Env.addLocals destructors env
424+ toNode defKeys key destructors $
425+ do cbody <- canonicalize newEnv body
426+ return $ Define region $
427+ Can.TypedDef aname freeVars args destructors cbody resultType
340
428
341
429
342−toNode :: Map.Map N.Name Int -> Map.Map N.Name a -> Int -> Result FreeLocals Binding -> Result () (Node, Int, [Int])
430+toNode :: Map.Map N.Name Int -> Int -> Map.Map N.Name a -> Result FreeLocals Binding -> Result () (Node, Int, [Int])
343−toNode defKeys args index (Result.Result freeLocals warnings answer) =
431+toNode defKeys key args (Result.Result freeLocals warnings answer) =
344 Result.Result () warnings $
432 Result.Result () warnings $
345 case answer of
433 case answer of
346 Result.Err err ->
434 Result.Err err ->
@@ -353,70 +441,91 @@ toNode defKeys args index (Result.Result freeLocals warnings answer) =
353 in
441 in
354 Result.Ok
442 Result.Ok
355 ( Node binding actuallyFreeLocals
443 ( Node binding actuallyFreeLocals
356− , index
444+ , key
357 , Map.elems locallyDefinedLocals
445 , Map.elems locallyDefinedLocals
358 )
446 )
359
447
360
448
361
449
450+-- GATHER TYPED ARGS
451+
452+
453+gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bag ([Can.TypedArg], Can.Type)
454+gatherTypedArgs env name srcArgs tipe index revTypedArgs =
455+ case srcArgs of
456+ [] ->
457+ return (reverse revTypedArgs, tipe)
458+
459+ srcArg : otherSrcArgs ->
460+ case Type.iteratedDealias tipe of
461+ Can.TLambda argType resultType ->
462+ do typedArg <- Can.TypedArg index argType
463+ <$> Pattern.canonicalize env index srcArg
464+ gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $
465+ typedArg : revTypedArgs
466+
467+ _ ->
468+ let (A.A start _, A.A end _) = (head srcArgs, last srcArgs) in
469+ Result.throw (R.merge start end) $
470+ Error.AnnotationTooShort name index (length srcArgs)
471+
472+
473+
362-- DETECT CYCLES
474-- DETECT CYCLES
363
475
364
476
365detectCycles :: R.Region -> [Graph.SCC Node] -> Can.Expr -> Result FreeLocals Can.Expr
477detectCycles :: R.Region -> [Graph.SCC Node] -> Can.Expr -> Result FreeLocals Can.Expr
366−detectCycles region sccs body =
478+detectCycles letRegion sccs body =
367 case sccs of
479 case sccs of
368 [] ->
480 [] ->
369 Result.ok body
481 Result.ok body
370
482
371 scc : subSccs ->
483 scc : subSccs ->
372− A.A region <$>
484+ A.A letRegion <$>
373 case scc of
485 case scc of
374 Graph.AcyclicSCC (Node binding freeLocals) ->
486 Graph.AcyclicSCC (Node binding freeLocals) ->
375 case binding of
487 case binding of
376 Define _ def ->
488 Define _ def ->
377 Result.accumulate freeLocals (Can.Let def)
489 Result.accumulate freeLocals (Can.Let def)
378− <*> detectCycles region subSccs body
490+ <*> detectCycles letRegion subSccs body
379
491
380 Destruct _ pattern destructors expr ->
492 Destruct _ pattern destructors expr ->
381 Result.accumulate freeLocals (Can.LetDestruct pattern destructors expr)
493 Result.accumulate freeLocals (Can.LetDestruct pattern destructors expr)
382− <*> detectCycles region subSccs body
494+ <*> detectCycles letRegion subSccs body
383
495
384 Graph.CyclicSCC nodes ->
496 Graph.CyclicSCC nodes ->
385− case unzip <$> traverse requireDefine nodes of
497+ case unzip <$> traverse requireFunction nodes of
386 Nothing ->
498 Nothing ->
387− Result.throw region (Error.RecursiveLet (map toCycleNodes nodes))
499+ Result.throw letRegion (Error.RecursiveLet (map toCycleNodes nodes))
388
500
389 Just (defs, freeLocals) ->
501 Just (defs, freeLocals) ->
390 Result.accumulate (Set.unions freeLocals) (Can.LetRec defs)
502 Result.accumulate (Set.unions freeLocals) (Can.LetRec defs)
391− <*> detectCycles region subSccs body
503+ <*> detectCycles letRegion subSccs body
392−
393
504
394
505
395−requireDefine :: Node -> Maybe (Can.Def, FreeLocals)
506+requireFunction :: Node -> Maybe (Can.Def, FreeLocals)
396−requireDefine (Node binding freeLocals) =
507+requireFunction (Node binding freeLocals) =
397 case binding of
508 case binding of
398− Define _ def@(Can.Def _ (Can.Args args _) _ _) ->
509+ Define _ def@(Can.Def _ (_:_) _ _) ->
399− case args of
510+ Just (def, freeLocals)
400− [] ->
401− Nothing
402
511
403− _ ->
512+ Define _ def@(Can.TypedDef _ _ (_:_) _ _ _) ->
404− Just (def, freeLocals)
513+ Just (def, freeLocals)
405
514
406− Destruct _ _ _ _ ->
515+ _ ->
407 Nothing
516 Nothing
408
517
409
518
410toCycleNodes :: Node -> Error.CycleNode
519toCycleNodes :: Node -> Error.CycleNode
411toCycleNodes (Node binding _) =
520toCycleNodes (Node binding _) =
412 case binding of
521 case binding of
413− Define _ (Can.Def name (Can.Args args _) _ _) ->
522+ Define _ def ->
414− case args of
523+ case def of
415− [] ->
524+ Can.Def name args _ _ ->
416− Error.CycleValue name
525+ if null args then Error.CycleValue name else Error.CycleFunc name
417
526
418− _ ->
527+ Can.TypedDef name _ args _ _ _ ->
419− Error.CycleFunc name
528+ if null args then Error.CycleValue name else Error.CycleFunc name
420
529
421 Destruct _ pattern _ _ ->
530 Destruct _ pattern _ _ ->
422 Error.CyclePattern pattern
531 Error.CyclePattern pattern
src/Canonicalize/Module.hs+43−57
@@ -21,12 +21,12 @@ import qualified Canonicalize.Environment.Local as Local
21import qualified Canonicalize.Expression as Expr
21import qualified Canonicalize.Expression as Expr
22import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Pattern as Pattern
23import qualified Canonicalize.Type as Type
23import qualified Canonicalize.Type as Type
24+import qualified Data.Index as Index
24import qualified Elm.Interface as I
25import qualified Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Elm.Name as N
26import qualified Elm.Package as Pkg
27import qualified Elm.Package as Pkg
27import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
28import qualified Reporting.Error.Canonicalize as Error
29import qualified Reporting.Error.Canonicalize as Error
29−import qualified Reporting.Region as R
30import qualified Reporting.Result as Result
30import qualified Reporting.Result as Result
31import qualified Reporting.Warning as Warning
31import qualified Reporting.Warning as Warning
32
32
@@ -142,7 +142,7 @@ canonicalizeDecls env decls =
142 detectCycles (Graph.stronglyConnComp nodes)
142 detectCycles (Graph.stronglyConnComp nodes)
143
143
144
144
145−detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
145+detectCycles :: [Graph.SCC Can.Def] -> Result Can.Decls
146detectCycles sccs =
146detectCycles sccs =
147 case sccs of
147 case sccs of
148 [] ->
148 [] ->
@@ -150,83 +150,69 @@ detectCycles sccs =
150
150
151 scc : otherSccs ->
151 scc : otherSccs ->
152 case scc of
152 case scc of
153− Graph.AcyclicSCC decl ->
153+ Graph.AcyclicSCC def ->
154− Can.Declare (toCanDecl decl)
155− <$> detectCycles otherSccs
154+ Can.Declare def <$> detectCycles otherSccs
156
155
157 Graph.CyclicSCC [] ->
156 Graph.CyclicSCC [] ->
158 detectCycles otherSccs
157 detectCycles otherSccs
159
158
160− Graph.CyclicSCC (decl:decls) ->
159+ Graph.CyclicSCC (def:defs) ->
161− do detectBadCycles decl decls
160+ do detectBadCycles def defs
162− Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
163− <$> detectCycles otherSccs
161+ Can.DeclareRec def defs <$> detectCycles otherSccs
164
162
165
163
166−toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
164+toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])
167−toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
165+toNode env (A.A _ (Valid.Decl aname@(A.A _ name) srcArgs body maybeType)) =
168− case args of
166+ case maybeType of
169− [] ->
167+ Nothing ->
170− do annotation <- traverse (Type.toAnnotation env) tipe
168+ do (args, destructors) <-
171− (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $
169+ Pattern.verify (Error.DPFuncArgs name) $
172− Expr.canonicalize env body
170+ Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
173− return
174− ( Value region name cbody annotation
175− , key
176− , Set.toList freeLocals
177− )
178
171
179− _ ->
180− do annotation <- traverse (Type.toAnnotation env) tipe
181− cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
182 newEnv <- Env.addLocals destructors env
172 newEnv <- Env.addLocals destructors env
173+ (cbody, freeLocals) <-
183− (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $
174+ Expr.removeLocals Warning.Pattern destructors $
184− Expr.canonicalize newEnv body
175+ Expr.canonicalize newEnv body
185− return
186− ( Function key cargs cbody annotation
187− , key
188− , Set.toList freeLocals
189− )
190
176
177+ let def = Can.Def aname args destructors cbody
178+ return (def, name, Set.toList freeLocals)
191
179
192−data Decl
180+ Just srcType ->
193− = Value R.Region (A.Located N.Name) Can.Expr (Maybe Can.Annotation)
181+ do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
194− | Function N.Name Can.Args Can.Expr (Maybe Can.Annotation)
195
182
183+ ((args,resultType), destructors) <-
184+ Pattern.verify (Error.DPFuncArgs name) $
185+ Expr.gatherTypedArgs env name srcArgs tipe Index.first []
196
186
197−toCanDecl :: Decl -> Can.Decl
187+ newEnv <- Env.addLocals destructors env
198−toCanDecl decl =
188+ (cbody, freeLocals) <-
199− case decl of
189+ Expr.removeLocals Warning.Pattern destructors $
200− Value _ (A.A _ name) body tipe ->
190+ Expr.canonicalize newEnv body
201− Can.Value name body tipe
202
191
203− Function name args body tipe ->
192+ let def = Can.TypedDef aname freeVars args destructors cbody resultType
204− Can.Function name args body tipe
193+ return (def, name, Set.toList freeLocals)
205
194
206
195
207−detectBadCycles :: Decl -> [Decl] -> Result ()
196+detectBadCycles :: Can.Def -> [Can.Def] -> Result ()
208−detectBadCycles decl decls =
197+detectBadCycles def defs =
209− case traverse detectBadCyclesHelp (decl:decls) of
198+ case (,) <$> detectBadCyclesHelp def <*> traverse detectBadCyclesHelp defs of
210 Nothing ->
199 Nothing ->
211 Result.ok ()
200 Result.ok ()
212
201
213− Just valueCycle ->
202+ Just (name, otherNames) ->
214− case valueCycle of
203+ Result.throw (error "TODO") (Error.RecursiveDecl name otherNames)
215− [] ->
216− Result.ok ()
217
204
218− (declRegion, A.A region name) : otherInfo ->
219− let otherNames = map (A.drop . snd) otherInfo in
220− Result.throw declRegion (Error.RecursiveDecl region name otherNames)
221
205
206+detectBadCyclesHelp :: Can.Def -> Maybe N.Name
207+detectBadCyclesHelp def =
208+ case def of
209+ Can.Def (A.A _ name) [] _ _ ->
210+ Just name
222
211
223−detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
212+ Can.TypedDef (A.A _ name) _ [] _ _ _ ->
224−detectBadCyclesHelp decl =
225− case decl of
226− Value region name _ _ ->
227− Just (region, name)
213+ Just name
228
214
229− Function _ _ _ _ ->
215+ _ ->
230 Nothing
216 Nothing
231
217
232
218
src/Canonicalize/Pattern.hs+19−88
@@ -1,19 +1,15 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
2module Canonicalize.Pattern
3+ ( verify
4+ , Bag
3− ( canonicalize
5+ , canonicalize
4− , canonicalizeArgs
6+ , canonicalizeArg
5− , canonicalizeBindings
6− , Binding(..)
7 )
7 )
8 where
8 where
9
9
10
10
11−import Control.Monad (zipWithM)
12−import qualified Data.Map.Strict as Map
13−
14import qualified AST.Canonical as Can
11import qualified AST.Canonical as Can
15import qualified AST.Source as Src
12import qualified AST.Source as Src
16−import qualified AST.Valid as Valid
17import qualified Canonicalize.Environment as Env
13import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
14import qualified Canonicalize.Environment.Dups as Dups
19import qualified Data.Bag as Bag
15import qualified Data.Bag as Bag
@@ -35,98 +31,28 @@ type Result i =
35
31
36
32
37
33
38−-- CANONICALIZE
34+-- VERIFY NAMES
39
35
40
36
41−canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result () (Can.Pattern, Can.Destructors)
37+verify :: Error.DuplicatePatternContext -> Result Bag a -> Result () (a, Can.Destructors)
42−canonicalize env index pattern =
38+verify context (Result.Result bag warnings answer) =
43− case process env (Can.DRoot index) pattern of
39+ case answer of
44− Result.Result bag warnings (Result.Ok cpattern) ->
40+ Result.Ok value ->
45− do let toError name () () = Error.DuplicateArg name
41+ do let toError name () () = Error.DuplicatePattern context name
46 destructors <- Dups.detect toError (Bag.toList bag)
42 destructors <- Dups.detect toError (Bag.toList bag)
47− Result.Result () warnings $ Result.Ok (cpattern, destructors)
43+ Result.Result () warnings $ Result.Ok (value, destructors)
48
44
49− Result.Result _ warnings (Result.Err err) ->
45+ Result.Err err ->
50 Result.Result () warnings (Result.Err err)
46 Result.Result () warnings (Result.Err err)
51
47
52
48
53
49
54−-- CANONICALIZE ARGS
50+-- CANONICALIZE ARG
55−
56−
57−canonicalizeArgs :: Env.Env -> [Src.Pattern] -> Result () Can.Args
58−canonicalizeArgs env patterns =
59− case Index.indexedTraverse (canonicalizeArg env) patterns of
60− Result.Result bag warnings (Result.Ok args) ->
61− do let toError name () () = Error.DuplicateArg name
62− destructors <- Dups.detect toError (Bag.toList bag)
63− Result.Result () warnings $ Result.Ok $
64− Can.Args args destructors
65−
66− Result.Result _ warnings (Result.Err err) ->
67− Result.Result () warnings (Result.Err err)
68
51
69
52
70canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
53canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
71canonicalizeArg env index pattern =
54canonicalizeArg env index pattern =
72− Can.Arg index <$> process env (Can.DRoot index) pattern
55+ Can.Arg index <$> canonicalize env index pattern
73−
74−
75−
76−-- CANONICALIZE BINDINGS
77−
78−
79−data Binding
80− = Define R.Region Int (A.Located N.Name) [Src.Pattern] Valid.Expr (Maybe Src.Type)
81− | Destruct R.Region Int Can.Pattern Can.Destructors Valid.Expr
82−
83−
84−canonicalizeBindings :: Env.Env -> [Valid.Def] -> Result () ( [Binding], Map.Map N.Name (A.Located Int) )
85−canonicalizeBindings env defs =
86− case zipWithM (canonicalizeBinding env) defs [ 0 .. length defs ] of
87− Result.Result bag warnings (Result.Ok cdefs) ->
88− do let toError name () () = Error.DuplicateBindingName name
89− nodes <- Dups.detect toError (Bag.toList bag)
90− Result.Result () warnings (Result.Ok (cdefs, nodes))
91−
92− Result.Result _ warnings (Result.Err err) ->
93− Result.Result () warnings (Result.Err err)
94−
95−
96−type KeyBag =
97− Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
98−
99−
100−canonicalizeBinding :: Env.Env -> Valid.Def -> Int -> Result KeyBag Binding
101−canonicalizeBinding env def index =
102− case def of
103− Valid.Define region aname@(A.A reg name) args body maybeType ->
104− let info = Dups.info name reg () (A.A region index) in
105− Result.accumulate (Bag.one info) $
106− Define region index aname args body maybeType
107−
108− Valid.Destruct region pattern body ->
109− case process env (Can.DRoot Index.first) pattern of
110− Result.Result bag warnings (Result.Ok cpattern) ->
111− do let toError name () () = Error.DuplicateBindingName name
112− destructors <- Result.untracked (Dups.detect toError (Bag.toList bag))
113− Result.Result (toKeyBag index bag) warnings $ Result.Ok $
114− Destruct region index cpattern destructors body
115−
116− Result.Result bag warnings (Result.Err err) ->
117− Result.Result (toKeyBag index bag) warnings (Result.Err err)
118−
119−
120−toKeyBag :: Int -> Bag -> KeyBag
121−toKeyBag index bag =
122− let
123− redoInfo (Dups.Info region () _) =
124− Dups.Info region () (A.A region index)
125−
126− replaceWithIndex ( name, infos ) =
127− ( name, map redoInfo infos )
128− in
129− Bag.map replaceWithIndex bag
130
56
131
57
132
58
@@ -137,6 +63,11 @@ type Bag =
137 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
63 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
138
64
139
65
66+canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Pattern
67+canonicalize env index pattern =
68+ process env (Can.DRoot index) pattern
69+
70+
140process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
71process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
141process env destructor (A.A region pattern) =
72process env destructor (A.A region pattern) =
142 A.A region <$>
73 A.A region <$>