a964796 · elk · git.iko.soy

git.iko.soy/elk

Shuffle canonicalization code to simplify type constraint generation

commita964796310e36efaea035c342c2a5c3f70a6de9a authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 14 Nov 2017, 21:36 (9 years ago) parentea793f5

4 files changed+242−222

compare with master

unifiedsplit

src/AST/Canonical.hs+17−23 src/Canonicalize/Expression.hs+163−54 src/Canonicalize/Module.hs+43−57 src/Canonicalize/Pattern.hs+19−88

src/AST/Canonical.hs+17−23

@@ -4,7 +4,8 @@ module AST.Canonical

44 ( Expr, Expr_(..)

55 , CaseBranch(..)

66 , Def(..)

7− , Args(..), Arg(..)

7+ , Arg(..)

8+ , TypedArg(..)

89 -- patterns

910 , Pattern, Pattern_(..)

1011 , PatternCtorArg(..)

@@ -16,7 +17,6 @@ module AST.Canonical

1617 , AliasType(..)

1718 -- decls

1819 , Decls(..)

19− , Decl(..)

2020 , Module(..)

2121 , Alias(..)

2222 , Union(..)

@@ -67,7 +67,7 @@ data Expr_

6767 | List [Expr]

6868 | Negate Expr

6969 | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr

70− | Lambda Args Expr

70+ | Lambda [Arg] Destructors Expr

7171 | Call Expr [Expr]

7272 | If [(Expr, Expr)] Expr

7373 | Let Def Expr

@@ -84,30 +84,26 @@ data Expr_

8484

8585

8686data CaseBranch =

87− CaseBranch

88− { _branch_index :: Index.ZeroBased

89− , _branch_pattern :: Pattern

90− , _branch_destructors :: Destructors

91− , _branch_expr :: Expr

92− }

87+ CaseBranch Pattern Destructors Expr

9388

9489

9590

9691-- DEFS

9792

9893

99−data Def =

100− Def (A.Located N.Name) Args Expr (Maybe Annotation)

101−

102−

103−data Args =

104− Args [Arg] Destructors

94+data Def

95+ = Def (A.Located N.Name) [Arg] Destructors Expr

96+ | TypedDef (A.Located N.Name) FreeVars [TypedArg] Destructors Expr Type

10597

10698

10799data Arg =

108100 Arg Index.ZeroBased Pattern

109101

110102

103+data TypedArg =

104+ TypedArg Index.ZeroBased Type Pattern

105+

106+

111107

112108-- PATTERNS

113109

@@ -155,7 +151,10 @@ data Destructor

155151-- TYPES

156152

157153

158−data Annotation = Forall (Map.Map N.Name ()) Type

154+data Annotation = Forall FreeVars Type

155+

156+

157+type FreeVars = Map.Map N.Name ()

159158

160159

161160data Type

@@ -178,16 +177,11 @@ data AliasType

178177

179178

180179data Decls

181− = Declare Decl Decls

182− | DeclareRec Decl [Decl] Decls

180+ = Declare Def Decls

181+ | DeclareRec Def [Def] Decls

183182 | SaveTheEnvironment

184183

185184

186−data Decl

187− = Value N.Name Expr (Maybe Annotation)

188− | Function N.Name Args Expr (Maybe Annotation)

189−

190−

191185

192186-- MODULES

193187

src/Canonicalize/Expression.hs+163−54

@@ -2,6 +2,7 @@

22module Canonicalize.Expression

33 ( canonicalize

44 , removeLocals

5+ , gatherTypedArgs

56 )

67 where

@@ -10,9 +11,10 @@ import qualified Data.Graph as Graph

1011import qualified Data.Map.Strict as Map

1112import qualified Data.Set as Set

1213

13−import qualified AST.Utils.Binop as Binop

1414import qualified AST.Canonical as Can

1515import qualified AST.Source as Src

16+import qualified AST.Utils.Binop as Binop

17+import qualified AST.Utils.Type as Type

1618import qualified AST.Valid as Valid

1719import qualified Canonicalize.Environment as Env

1820import qualified Canonicalize.Environment.Dups as Dups

@@ -76,12 +78,14 @@ canonicalize env (A.A region expression) =

7678 Valid.Binops ops final ->

7779 A.drop <$> canonicalizeBinops region env ops final

7880

79− Valid.Lambda args body ->

81+ Valid.Lambda srcArgs body ->

8082 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

8286 newEnv <- Env.addLocals destructors env

8387 removeLocals Warning.Pattern destructors $

84− Can.Lambda cargs <$> canonicalize newEnv body

88+ Can.Lambda args destructors <$> canonicalize newEnv body

8589

8690 Valid.Call func args ->

8791 Can.Call

@@ -99,7 +103,7 @@ canonicalize env (A.A region expression) =

99103 Valid.Case expr branches ->

100104 Can.Case

101105 <$> canonicalize env expr

102− <*> Index.indexedTraverse (canonicalizeCaseBranch env) branches

106+ <*> traverse (canonicalizeCaseBranch env) branches

103107

104108 Valid.Accessor field ->

105109 Result.ok $ Can.Accessor field

@@ -165,13 +169,15 @@ canonicalizeIfBranch env (condition, branch) =

165169-- CANONICALIZE CASE BRANCH

166170

167171

168−canonicalizeCaseBranch :: Env.Env -> Index.ZeroBased -> (Src.Pattern, Valid.Expr) -> Result FreeLocals Can.CaseBranch

169−canonicalizeCaseBranch env index (pattern, expr) =

172+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals Can.CaseBranch

173+canonicalizeCaseBranch env (pattern, expr) =

170174 addLocals $

171− do (cpattern, destructors) <- Pattern.canonicalize env index pattern

175+ do (cpattern, destructors) <-

176+ Pattern.verify Error.DPCaseBranch $

177+ Pattern.canonicalize env Index.first pattern

172178 newEnv <- Env.addLocals destructors env

173179 removeLocals Warning.Pattern destructors $

174− Can.CaseBranch index cpattern destructors <$> canonicalize newEnv expr

180+ Can.CaseBranch cpattern destructors <$> canonicalize newEnv expr

175181

176182

177183

@@ -262,15 +268,18 @@ toBinop (Env.Binop op home name annotation _ _) left right =

262268

263269

264270canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals Can.Expr

265−canonicalizeLet region env defs body =

271+canonicalizeLet letRegion env defs body =

266272 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)

268277 newEnv <- Env.addLocals boundNames env

269278 let defKeys = Map.map A.drop boundNames

270− nodes <- Result.untracked $ traverse (bindingToNode defKeys newEnv) bindings

279+ nodes <- traverse (defToNode defKeys newEnv) keyedDefs

271280 removeLocals Warning.Binding boundNames $

272281 do cbody <- canonicalize env body

273− detectCycles region (Graph.stronglyConnComp nodes) cbody

282+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody

274283

275284

276285addLocals :: Result () (expr, FreeLocals) -> Result FreeLocals expr

@@ -312,35 +321,114 @@ toUnusedWarning unused (name, A.A region _) =

312321

313322

314323

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+

315386-- BUILD BINDINGS GRAPH

316387

317388

389+data Node = Node Binding FreeLocals

390+

391+

318392data Binding

319393 = Define R.Region Can.Def

320394 | Destruct R.Region Can.Pattern Can.Destructors Can.Expr

321395

322396

323−data Node = Node Binding FreeLocals

324−

325−

326−bindingToNode :: Map.Map N.Name Int -> Env.Env -> Pattern.Binding -> Result () (Node, Int, [Int])

327−bindingToNode defKeys env binding =

328− case binding of

329− Pattern.Define region index name args body maybeType ->

330− do cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args

331− maybeAnnotation <- traverse (Type.toAnnotation env) maybeType

397+defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result () (Node, Int, [Int])

398+defToNode defKeys env (def, key) =

399+ case def of

400+ Valid.Define region aname@(A.A _ name) srcArgs body Nothing ->

401+ do (args, destructors) <-

402+ Pattern.verify (Error.DPFuncArgs name) $

403+ Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs

332404 newEnv <- Env.addLocals destructors env

333− toNode defKeys destructors index $

405+ toNode defKeys key destructors $

334406 do cbody <- canonicalize newEnv body

335− return $ Define region $ Can.Def name cargs cbody maybeAnnotation

336−

337− Pattern.Destruct region index pattern destructors body ->

338− toNode defKeys Map.empty index $

339− Destruct region pattern destructors <$> canonicalize env body

407+ return $ Define region $

408+ Can.Def aname args destructors cbody

409+

410+ Valid.Destruct region pattern body ->

411+ do (cpattern, destructors) <-

412+ Pattern.verify Error.DPDestruct $

413+ Pattern.canonicalize env Index.first pattern

414+

415+ toNode defKeys key destructors $

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

340428

341429

342−toNode :: Map.Map N.Name Int -> Map.Map N.Name a -> Int -> Result FreeLocals Binding -> Result () (Node, Int, [Int])

343−toNode defKeys args index (Result.Result freeLocals warnings answer) =

430+toNode :: Map.Map N.Name Int -> Int -> Map.Map N.Name a -> Result FreeLocals Binding -> Result () (Node, Int, [Int])

431+toNode defKeys key args (Result.Result freeLocals warnings answer) =

344432 Result.Result () warnings $

345433 case answer of

346434 Result.Err err ->

@@ -353,70 +441,91 @@ toNode defKeys args index (Result.Result freeLocals warnings answer) =

353441 in

354442 Result.Ok

355443 ( Node binding actuallyFreeLocals

356− , index

444+ , key

357445 , Map.elems locallyDefinedLocals

358446 )

359447

360448

361449

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+

362474-- DETECT CYCLES

363475

364476

365477detectCycles :: R.Region -> [Graph.SCC Node] -> Can.Expr -> Result FreeLocals Can.Expr

366−detectCycles region sccs body =

478+detectCycles letRegion sccs body =

367479 case sccs of

368480 [] ->

369481 Result.ok body

370482

371483 scc : subSccs ->

372− A.A region <$>

484+ A.A letRegion <$>

373485 case scc of

374486 Graph.AcyclicSCC (Node binding freeLocals) ->

375487 case binding of

376488 Define _ def ->

377489 Result.accumulate freeLocals (Can.Let def)

378− <*> detectCycles region subSccs body

490+ <*> detectCycles letRegion subSccs body

379491

380492 Destruct _ pattern destructors expr ->

381493 Result.accumulate freeLocals (Can.LetDestruct pattern destructors expr)

382− <*> detectCycles region subSccs body

494+ <*> detectCycles letRegion subSccs body

383495

384496 Graph.CyclicSCC nodes ->

385− case unzip <$> traverse requireDefine nodes of

497+ case unzip <$> traverse requireFunction nodes of

386498 Nothing ->

387− Result.throw region (Error.RecursiveLet (map toCycleNodes nodes))

499+ Result.throw letRegion (Error.RecursiveLet (map toCycleNodes nodes))

388500

389501 Just (defs, freeLocals) ->

390502 Result.accumulate (Set.unions freeLocals) (Can.LetRec defs)

391− <*> detectCycles region subSccs body

392−

503+ <*> detectCycles letRegion subSccs body

393504

394505

395−requireDefine :: Node -> Maybe (Can.Def, FreeLocals)

396−requireDefine (Node binding freeLocals) =

506+requireFunction :: Node -> Maybe (Can.Def, FreeLocals)

507+requireFunction (Node binding freeLocals) =

397508 case binding of

398− Define _ def@(Can.Def _ (Can.Args args _) _ _) ->

399− case args of

400− [] ->

401− Nothing

509+ Define _ def@(Can.Def _ (_:_) _ _) ->

510+ Just (def, freeLocals)

402511

403− _ ->

404− Just (def, freeLocals)

512+ Define _ def@(Can.TypedDef _ _ (_:_) _ _ _) ->

513+ Just (def, freeLocals)

405514

406− Destruct _ _ _ _ ->

515+ _ ->

407516 Nothing

408517

409518

410519toCycleNodes :: Node -> Error.CycleNode

411520toCycleNodes (Node binding _) =

412521 case binding of

413− Define _ (Can.Def name (Can.Args args _) _ _) ->

414− case args of

415− [] ->

416− Error.CycleValue name

522+ Define _ def ->

523+ case def of

524+ Can.Def name args _ _ ->

525+ if null args then Error.CycleValue name else Error.CycleFunc name

417526

418− _ ->

419− Error.CycleFunc name

527+ Can.TypedDef name _ args _ _ _ ->

528+ if null args then Error.CycleValue name else Error.CycleFunc name

420529

421530 Destruct _ pattern _ _ ->

422531 Error.CyclePattern pattern

src/Canonicalize/Module.hs+43−57

@@ -21,12 +21,12 @@ import qualified Canonicalize.Environment.Local as Local

2121import qualified Canonicalize.Expression as Expr

2222import qualified Canonicalize.Pattern as Pattern

2323import qualified Canonicalize.Type as Type

24+import qualified Data.Index as Index

2425import qualified Elm.Interface as I

2526import qualified Elm.Name as N

2627import qualified Elm.Package as Pkg

2728import qualified Reporting.Annotation as A

2829import qualified Reporting.Error.Canonicalize as Error

29−import qualified Reporting.Region as R

3030import qualified Reporting.Result as Result

3131import qualified Reporting.Warning as Warning

3232

@@ -142,7 +142,7 @@ canonicalizeDecls env decls =

142142 detectCycles (Graph.stronglyConnComp nodes)

143143

144144

145−detectCycles :: [Graph.SCC Decl] -> Result Can.Decls

145+detectCycles :: [Graph.SCC Can.Def] -> Result Can.Decls

146146detectCycles sccs =

147147 case sccs of

148148 [] ->

@@ -150,83 +150,69 @@ detectCycles sccs =

150150

151151 scc : otherSccs ->

152152 case scc of

153− Graph.AcyclicSCC decl ->

154− Can.Declare (toCanDecl decl)

155− <$> detectCycles otherSccs

153+ Graph.AcyclicSCC def ->

154+ Can.Declare def <$> detectCycles otherSccs

156155

157156 Graph.CyclicSCC [] ->

158157 detectCycles otherSccs

159158

160− Graph.CyclicSCC (decl:decls) ->

161− do detectBadCycles decl decls

162− Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)

163− <$> detectCycles otherSccs

159+ Graph.CyclicSCC (def:defs) ->

160+ do detectBadCycles def defs

161+ Can.DeclareRec def defs <$> detectCycles otherSccs

164162

165163

166−toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])

167−toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =

168− case args of

169− [] ->

170− do annotation <- traverse (Type.toAnnotation env) tipe

171− (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $

172− Expr.canonicalize env body

173− return

174− ( Value region name cbody annotation

175− , key

176− , Set.toList freeLocals

177− )

164+toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])

165+toNode env (A.A _ (Valid.Decl aname@(A.A _ name) srcArgs body maybeType)) =

166+ case maybeType of

167+ Nothing ->

168+ do (args, destructors) <-

169+ Pattern.verify (Error.DPFuncArgs name) $

170+ Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs

178171

179− _ ->

180− do annotation <- traverse (Type.toAnnotation env) tipe

181− cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args

182172 newEnv <- Env.addLocals destructors env

183− (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $

184− Expr.canonicalize newEnv body

185− return

186− ( Function key cargs cbody annotation

187− , key

188− , Set.toList freeLocals

189− )

173+ (cbody, freeLocals) <-

174+ Expr.removeLocals Warning.Pattern destructors $

175+ Expr.canonicalize newEnv body

190176

177+ let def = Can.Def aname args destructors cbody

178+ return (def, name, Set.toList freeLocals)

191179

192−data Decl

193− = Value R.Region (A.Located N.Name) Can.Expr (Maybe Can.Annotation)

194− | Function N.Name Can.Args Can.Expr (Maybe Can.Annotation)

180+ Just srcType ->

181+ do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType

195182

183+ ((args,resultType), destructors) <-

184+ Pattern.verify (Error.DPFuncArgs name) $

185+ Expr.gatherTypedArgs env name srcArgs tipe Index.first []

196186

197−toCanDecl :: Decl -> Can.Decl

198−toCanDecl decl =

199− case decl of

200− Value _ (A.A _ name) body tipe ->

201− Can.Value name body tipe

187+ newEnv <- Env.addLocals destructors env

188+ (cbody, freeLocals) <-

189+ Expr.removeLocals Warning.Pattern destructors $

190+ Expr.canonicalize newEnv body

202191

203− Function name args body tipe ->

204− Can.Function name args body tipe

192+ let def = Can.TypedDef aname freeVars args destructors cbody resultType

193+ return (def, name, Set.toList freeLocals)

205194

206195

207−detectBadCycles :: Decl -> [Decl] -> Result ()

208−detectBadCycles decl decls =

209− case traverse detectBadCyclesHelp (decl:decls) of

196+detectBadCycles :: Can.Def -> [Can.Def] -> Result ()

197+detectBadCycles def defs =

198+ case (,) <$> detectBadCyclesHelp def <*> traverse detectBadCyclesHelp defs of

210199 Nothing ->

211200 Result.ok ()

212201

213− Just valueCycle ->

214− case valueCycle of

215− [] ->

216− Result.ok ()

202+ Just (name, otherNames) ->

203+ Result.throw (error "TODO") (Error.RecursiveDecl name otherNames)

217204

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)

221205

206+detectBadCyclesHelp :: Can.Def -> Maybe N.Name

207+detectBadCyclesHelp def =

208+ case def of

209+ Can.Def (A.A _ name) [] _ _ ->

210+ Just name

222211

223−detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)

224−detectBadCyclesHelp decl =

225− case decl of

226− Value region name _ _ ->

227− Just (region, name)

212+ Can.TypedDef (A.A _ name) _ [] _ _ _ ->

213+ Just name

228214

229− Function _ _ _ _ ->

215+ _ ->

230216 Nothing

231217

232218

src/Canonicalize/Pattern.hs+19−88

@@ -1,19 +1,15 @@

11{-# OPTIONS_GHC -Wall #-}

22module Canonicalize.Pattern

3− ( canonicalize

4− , canonicalizeArgs

5− , canonicalizeBindings

6− , Binding(..)

3+ ( verify

4+ , Bag

5+ , canonicalize

6+ , canonicalizeArg

77 )

88 where

1010

11−import Control.Monad (zipWithM)

12−import qualified Data.Map.Strict as Map

13−

1411import qualified AST.Canonical as Can

1512import qualified AST.Source as Src

16−import qualified AST.Valid as Valid

1713import qualified Canonicalize.Environment as Env

1814import qualified Canonicalize.Environment.Dups as Dups

1915import qualified Data.Bag as Bag

@@ -35,98 +31,28 @@ type Result i =

3531

3632

3733

38−-- CANONICALIZE

34+-- VERIFY NAMES

3935

4036

41−canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result () (Can.Pattern, Can.Destructors)

42−canonicalize env index pattern =

43− case process env (Can.DRoot index) pattern of

44− Result.Result bag warnings (Result.Ok cpattern) ->

45− do let toError name () () = Error.DuplicateArg name

37+verify :: Error.DuplicatePatternContext -> Result Bag a -> Result () (a, Can.Destructors)

38+verify context (Result.Result bag warnings answer) =

39+ case answer of

40+ Result.Ok value ->

41+ do let toError name () () = Error.DuplicatePattern context name

4642 destructors <- Dups.detect toError (Bag.toList bag)

47− Result.Result () warnings $ Result.Ok (cpattern, destructors)

43+ Result.Result () warnings $ Result.Ok (value, destructors)

4844

49− Result.Result _ warnings (Result.Err err) ->

45+ Result.Err err ->

5046 Result.Result () warnings (Result.Err err)

5147

5248

5349

54−-- CANONICALIZE ARGS

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)

50+-- CANONICALIZE ARG

6851

6952

7053canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg

7154canonicalizeArg env index pattern =

72− Can.Arg index <$> process env (Can.DRoot 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

55+ Can.Arg index <$> canonicalize env index pattern

13056

13157

13258

@@ -137,6 +63,11 @@ type Bag =

13763 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])

13864

13965

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+

14071process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern

14172process env destructor (A.A region pattern) =

14273 A.A region <$>