fcbda99 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get canonicalization of module going again

fcbda99Evan Czaplicki9 years ago

src/AST/Expression/Canonical.hs+13−13

compare with master

unifiedsplit

@@ -10,6 +10,7 @@ module AST.Expression.Canonical

10 , Destructors

11 , Destructor(..)

12 -- decls

13+ , Decls(..)

13 , Decl(..)

14 , Decl(..)

14 , Module(..)

15 , Module(..)

15 , Alias(..)

16 , Alias(..)

@@ -24,7 +25,6 @@ module AST.Expression.Canonical

25import Control.Monad (liftM2, liftM3)

26import Control.Monad (liftM2, liftM3)

26import Data.Binary

27import Data.Binary

27−import qualified Data.Graph as Graph

28import qualified Data.Map as Map

29import Data.Text (Text)

@@ -32,7 +32,6 @@ import qualified AST.Binop as Binop

32import qualified AST.Literal as Literal

33import qualified AST.Module.Name as ModuleName

34import qualified AST.Type as Type

35−import qualified AST.Variable as Var

36import qualified Elm.Name as N

35import qualified Elm.Name as N

37import Elm.Name (Name)

36import Elm.Name (Name)

38import qualified Reporting.Annotation as A

37import qualified Reporting.Annotation as A

@@ -83,7 +82,7 @@ data Def =

83 { _def_name :: A.Located N.Name

82 { _def_name :: A.Located N.Name

84 , _def_args :: Args

83 , _def_args :: Args

85 , _def_body :: Expr

84 , _def_body :: Expr

86− , _def_type :: Maybe (A.Located Type.Canonical)

85+ , _def_type :: Maybe Type.Canonical

87 }

86 }

@@ -124,26 +123,27 @@ data Destructor

124-- DECLARATIONS

123-- DECLARATIONS

125

124

126

125

127−data Decl =

126+data Decls

128− Decl

127+ = Declare Decl Decls

129− { _top_name :: N.Name

128+ | DeclareRec Decl [Decl] Decls

130− , _top_args :: Args

129+ | SaveTheEnvironment

131− , _top_body :: Expr

130+

132− , _top_type :: Maybe (A.Located Type.Canonical)

131+

133− , _top_deps :: [Var.Global]

132+data Decl

134− }

133+ = Value N.Name Expr (Maybe Type.Canonical)

134+ | Function N.Name Args Expr (Maybe Type.Canonical)

135

136

137

138-- MODULES

139

140

141−data Module phase =

141+data Module =

142 Module

143 { _name :: ModuleName.Canonical

144 , _docs :: A.Located (Maybe Docs)

145 , _imports :: [N.Name]

146− , _decls :: [Graph.SCC Decl]

146+ , _decls :: Decls

147 , _unions :: Map.Map N.Name Union

148 , _aliases :: Map.Map N.Name Alias

149 , _binops :: Map.Map N.Name Binop

src/AST/Expression/Valid.hs+1−1

@@ -74,7 +74,7 @@ data Module =

74 , _docs :: Map.Map N.Name Text

75 , _exports :: Src.Exposing

76 , _imports :: [Src.Import]

77− , _decls :: [Decl]

77+ , _decls :: [A.Located Decl]

78 , _unions :: [Union]

79 , _aliases :: [Alias]

80 , _binop :: [Binop]

src/Canonicalize.hsdeleted−478

@@ -1,478 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize (module') where

3−

4−import Prelude hiding (last)

5−import qualified Data.Foldable as T

6−import Data.List.NonEmpty (NonEmpty((:|)))

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9−import qualified Data.Maybe as Maybe

10−import qualified Data.Set as Set

11−import Data.Text (Text)

12−

13−import qualified AST.Declaration as D

14−import qualified AST.Effects as Effects

15−import qualified AST.Exposing as Exposing

16−import qualified AST.Expression.Source as Src

17−import qualified AST.Expression.Canonical as C

18−import qualified AST.Module as Module

19−import qualified AST.Module.Name as ModuleName

20−import qualified AST.Pattern as P

21−import qualified AST.Type as Type

22−import qualified AST.Variable as Var

23−import qualified Canonicalize.Binops as Binops

24−import qualified Canonicalize.Body as Body

25−import qualified Canonicalize.Effects as Effects

26−import qualified Canonicalize.Environment as Env

27−import qualified Canonicalize.Setup as Setup

28−import qualified Canonicalize.Type as Canon

29−import qualified Canonicalize.Variable as Canon

30−import qualified Docs.Centralize as Docs

31−import qualified Reporting.Annotation as A

32−import qualified Reporting.Error as Error

33−import qualified Reporting.Error.Canonicalize as CError

34−import qualified Reporting.Helpers as Help

35−import qualified Reporting.Region as Region

36−import qualified Reporting.Render.Type as RenderType

37−import qualified Reporting.Result as Result

38−import qualified Reporting.Warning as Warning

39−

40−

41−

42−type Result a =

43− Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a

44−

45−

46−-- MODULES

47−

48−

49−module'

50− :: Map.Map ModuleName.Raw ModuleName.Canonical

51− -> Module.Interfaces

52− -> Module.Valid

53− -> Result Module.Canonical

54−module' importDict interfaces modul =

55− let

56− (Module.Valid docs exports imports decls effects) =

57− Module.info modul

58−

59− (Result.Result uses warnings rawResults) =

60− do env <- Setup.environment importDict interfaces modul

61−

62− (,,,) env

63− <$> resolveExports (getInternalApi effects decls) exports

64− <*> canonicalizeDecls env decls

65− <*> Effects.canonicalize env effects

66− in

67− case rawResults of

68− Result.Err errors ->

69− Result.mapError Error.Canonicalize $

70− Result.Result Result.None warnings (Result.Err errors)

71−

72− Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->

73− let

74− (D.Decls _ unions aliases infixes) =

75− canonicalDecls

76−

77− centralizedDocs =

78− A.map (fmap (Docs.centralize canonicalDecls)) docs

79−

80− typeToPair (A.A _ (D.Type name args body)) =

81− ( name, (args, body) )

82−

83− getProgram =

84− Body.flatten (Module.name modul) canonicalDecls canonicalEffects

85− in

86− do program <- Result.mapError Error.Canonicalize getProgram

87− canonicalImports <- filterImports uses imports

88− Result.accumulate (Result.One (Env.toLocalizer env)) $

89− modul {

90− Module.info =

91− Module.Info

92− { Module.docs = centralizedDocs

93− , Module.exports = canonicalExports

94− , Module.imports = canonicalImports

95− , Module.program = program

96− , Module.types = Map.empty

97− , Module.fixities = infixes

98− , Module.aliases = Map.fromList (map typeToPair aliases)

99− , Module.unions = Map.fromList (map typeToPair unions)

100− , Module.effects = canonicalEffects

101− }

102− }

103−

104−

105−

106−-- IMPORTS

107−

108−

109−filterImports

110− :: Set.Set ModuleName.Raw

111− -> ([Module.DefaultImport], [Module.UserImport])

112− -> Result [ModuleName.Raw]

113−filterImports uses (defaults, imports) =

114− let

115− checkImport (A.A region (A.A _ name, _method)) =

116− if Set.member name uses then

117− return (Just name)

118−

119− else

120− Result.warn region (Warning.UnusedImport name) Nothing

121− in

122− do reducedImports <-

123− Maybe.catMaybes <$> traverse checkImport imports

124−

125− return $

126− Set.toList (Set.fromList (map fst defaults ++ reducedImports))

127−

128−

129−

130−-------- CANONICALIZATION --------

131−

132−

133−type CResult a =

134− Canon.Result a

135−

136−

137−

138−-- EXPORTS

139−

140−

141−resolveExports :: Exposing.Canonical -> Exposing.Raw -> CResult Exposing.Canonical

142−resolveExports internalApi@(Exposing.Canonical values aliases unions) rawExposing =

143− case rawExposing of

144− Exposing.Open ->

145− Result.ok internalApi

146−

147− Exposing.Explicit entries ->

148− let

149− valueSet = Set.fromList values

150− aliasSet = Set.fromList aliases

151− unionMap = Map.fromList unions

152− in

153− case List.foldl' (resolveEntry valueSet aliasSet unionMap) (Exposing.nothing, []) entries of

154− (exposing, []) ->

155− do checkForDups entries

156− Result.ok exposing

157−

158− (_, errors) ->

159− Result.throwMany errors

160−

161−

162−resolveEntry

163− :: Set.Set Text

164− -> Set.Set Text

165− -> Map.Map Text [Text]

166− -> (Exposing.Canonical, [A.Located CError.Error])

167− -> A.Located Exposing.Entry

168− -> (Exposing.Canonical, [A.Located CError.Error])

169−resolveEntry vSet aSet uSet (exposing@(Exposing.Canonical values aliases unions), errors) (A.A region entry) =

170− case entry of

171− Exposing.Lower name ->

172− if Set.member name vSet then

173− ( Exposing.Canonical (name:values) aliases unions

174− , errors

175− )

176−

177− else

178− ( exposing

179− , notFound region (Set.toList vSet) name : errors

180− )

181−

182− Exposing.Upper name Nothing ->

183− if Set.member name aSet then

184− ( Exposing.Canonical

185− (if Set.member name vSet then name:values else values)

186− (name:aliases)

187− unions

188− , errors

189− )

190−

191− else if Map.member name uSet then

192− ( Exposing.Canonical values aliases ((name, []) : unions)

193− , errors

194− )

195−

196− else

197− ( exposing

198− , notFound region (Set.toList aSet ++ Map.keys uSet) name : errors

199− )

200−

201− Exposing.Upper name (Just exposedCtors) ->

202− case Map.lookup name uSet of

203− Nothing ->

204− ( exposing

205− , notFound region (Map.keys uSet) name : errors

206− )

207−

208− Just allCtors ->

209− case exposedCtors of

210− Exposing.Open ->

211− ( Exposing.Canonical values aliases ((name, allCtors) : unions)

212− , errors

213− )

214−

215− Exposing.Explicit ctors ->

216− let

217− isNotKnown (A.A _ ctor) =

218− ctor `notElem` allCtors

219−

220− notKnown (A.A ctorRegion ctor) =

221− notFound ctorRegion allCtors ctor

222− in

223− case filter isNotKnown ctors of

224− [] ->

225− ( Exposing.Canonical values aliases ((name, map A.drop ctors) : unions)

226− , errors

227− )

228−

229− unfoundCtors ->

230− ( exposing

231− , map notKnown unfoundCtors ++ errors

232− )

233−

234−

235−notFound :: Region.Region -> [Text] -> Text -> A.Located CError.Error

236−notFound region possibilities badName =

237− A.A region $ CError.Export badName $

238− Help.nearbyNames id badName possibilities

239−

240−

241−checkForDups :: [A.Located Exposing.Entry] -> CResult ()

242−checkForDups entries =

243− let

244− locations =

245− A.listToDict Exposing.getName entries

246−

247− isUnique name (region :| duplicates) =

248− case duplicates of

249− [] ->

250− Result.ok ()

251−

252− _ ->

253− Result.throw region (CError.DuplicateExport name)

254− in

255− T.sequenceA_ (Map.mapWithKey isUnique locations)

256−

257−

258−

259−-- ALL POSSIBLE EXPOSED VALUES

260−

261−

262−getInternalApi :: Effects.Raw -> D.Valid -> Exposing.Canonical

263−getInternalApi effects (D.Decls defs unions aliases _) =

264− let

265− values =

266− Effects.toExposedValues effects

267− ++ concatMap getAliasValues aliases

268− ++ concatMap getDefValues defs

269− in

270− Exposing.Canonical values (map getAlias aliases) (map getUnion unions)

271−

272−

273−getDefValues :: A.Commented Src.ValidDef -> [Text]

274−getDefValues (A.A _ def) =

275− P.boundVarList (Src.getPattern def)

276−

277−

278−getAliasValues :: A.Commented (D.Alias Type.Raw) -> [Text]

279−getAliasValues (A.A _ (D.Type name _ tipe)) =

280− case tipe of

281− A.A _ (Type.RRecord _ Nothing) ->

282− [ name ]

283−

284− _ ->

285− []

286−

287−

288−getAlias :: A.Commented (D.Alias Type.Raw) -> Text

289−getAlias (A.A _ (D.Type name _ _)) =

290− name

291−

292−

293−getUnion :: A.Commented (D.Union Type.Raw) -> (Text, [Text])

294−getUnion (A.A _ (D.Type name _ ctors)) =

295− (name, map fst ctors)

296−

297−

298−

299−-- DECLARATIONS

300−

301−

302−canonicalizeDecls :: Env.Env -> D.Valid -> CResult D.Canonical

303−canonicalizeDecls env (D.Decls defs unions aliases infixes) =

304− let

305− annTraverse canEntry entries =

306− traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

307−

308− canonicalizeDef (Src.Def region pat expr typ) =

309− C.Def region

310− <$> canonicalizePattern env pat

311− <*> canonicalizeExpr env expr

312− <*> traverse (canonicalizeRegionType env) typ

313−

314− canonicalizeArgs (ctor, args) =

315− (,) ctor <$> traverse (Canon.tipe env) args

316−

317− canonicalizeUnion (D.Type name tvars ctors) =

318− D.Type name tvars <$> traverse canonicalizeArgs ctors

319−

320− canonicalizeAlias (D.Type name tvars alias) =

321− D.Type name tvars <$> Canon.tipe env alias

322− in

323− D.Decls

324− <$> annTraverse canonicalizeDef defs

325− <*> annTraverse canonicalizeUnion unions

326− <*> annTraverse canonicalizeAlias aliases

327− <*> pure infixes

328−

329−

330−canonicalizeRegionType :: Env.Env -> Type.Raw -> CResult (A.Located Type.Canonical)

331−canonicalizeRegionType env typ@(A.A region _) =

332− A.A region <$> Canon.tipe env typ

333−

334−

335−

336−-- EXPRESSIONS

337−

338−

339−canonicalizeExpr :: Env.Env -> Src.ValidExpr -> CResult C.Expr

340−canonicalizeExpr env (A.A region validExpr) =

341− let go = canonicalizeExpr env

342− in

343− A.A region <$>

344− case validExpr of

345− Src.Literal lit ->

346− Result.ok (C.Literal lit)

347−

348− Src.Access record field ->

349− C.Access <$> go record <*> Result.ok field

350−

351− Src.Update record fields ->

352− C.Update <$> go record <*> traverse (canonicalizeFields env) fields

353−

354− Src.Record fields ->

355− C.Record <$> traverse (canonicalizeFields env) fields

356−

357− Src.Binop ops last ->

358− canonicalizeBinop region env ops last

359−

360− Src.Lambda arg body ->

361− let

362− env' =

363− Env.addPattern arg env

364− in

365− C.Lambda

366− <$> canonicalizePattern env' arg

367− <*> canonicalizeExpr env' body

368−

369− Src.App func arg ->

370− C.App <$> go func <*> go arg

371−

372− Src.If branches finally ->

373− C.If

374− <$> traverse go' branches

375− <*> go finally

376− where

377− go' (condition, branch) =

378− (,) <$> go condition <*> go branch

379−

380− Src.Let defs expr ->

381− C.Let <$> traverse rename' defs <*> canonicalizeExpr env' expr

382− where

383− env' =

384− foldr Env.addPattern env (map Src.getPattern defs)

385−

386− rename' (Src.Def defRegion p body mtipe) =

387− C.Def defRegion

388− <$> canonicalizePattern env' p

389− <*> canonicalizeExpr env' body

390− <*> traverse (canonicalizeRegionType env') mtipe

391−

392− Src.Var (Var.Raw x) ->

393− C.Var <$> Canon.variable region env x

394−

395− Src.Ctor name exprs ->

396− C.Ctor

397− <$> Canon.variable region env name

398− <*> traverse go exprs

399−

400− Src.List exprs ->

401− C.List <$> traverse go exprs

402−

403− Src.Case expr cases ->

404− C.Case <$> go expr <*> traverse branch cases

405− where

406− branch (ptrn, brnch) =

407− (,)

408− <$> canonicalizePattern env ptrn

409− <*> canonicalizeExpr (Env.addPattern ptrn env) brnch

410−

411− Src.GLShader uid src tipe ->

412− Result.ok (C.GLShader uid src tipe)

413−

414−

415−canonicalizeFields

416− :: Env.Env

417− -> (A.Located Text, Src.ValidExpr)

418− -> CResult (Text, C.Expr)

419−canonicalizeFields env (A.A _ key, expr) =

420− (\value -> (key, value)) <$> canonicalizeExpr env expr

421−

422−

423−

424−-- PATTERNS

425−

426−

427−canonicalizePattern :: Env.Env -> P.Raw -> CResult P.Canonical

428−canonicalizePattern env (A.A region ptrn) =

429− A.A region <$>

430− case ptrn of

431− P.Var x ->

432− Result.ok (P.Var x)

433−

434− P.Literal lit ->

435− Result.ok (P.Literal lit)

436−

437− P.Record fields ->

438− Result.ok (P.Record fields)

439−

440− P.Anything ->

441− Result.ok P.Anything

442−

443− P.Alias x p ->

444− P.Alias x <$> canonicalizePattern env p

445−

446− P.Ctor (Var.Raw name) patterns ->

447− P.Ctor

448− <$> Canon.pvar region env name (length patterns)

449− <*> traverse (canonicalizePattern env) patterns

450−

451−

452−

453−-- BINOPS

454−

455−

456−canonicalizeBinop

457− :: Region.Region

458− -> Env.Env

459− -> [(Src.ValidExpr, A.Located Text)]

460− -> Src.ValidExpr

461− -> CResult C.Expr'

462−canonicalizeBinop region env srcOps srcLast =

463− let

464− opsResult =

465− traverse (binopHelp env) srcOps

466−

467− lastResult =

468− canonicalizeExpr env srcLast

469− in

470− do (expr, ops) <- (,) <$> opsResult <*> lastResult

471− A.drop <$> Binops.flatten region expr ops

472−

473−

474−binopHelp :: Env.Env -> (Src.ValidExpr, A.Located Text) -> CResult (C.Expr, Binops.Op)

475−binopHelp env (expr, op) =

476− (,)

477− <$> canonicalizeExpr env expr

478− <*> Binops.canonicalize env op

src/Canonicalize/Environment/Local.hs+8−4

@@ -143,7 +143,7 @@ addVarsHelp localVars vars =

143collectLowerVars :: Valid.Module -> Result (Map.Map N.Name ())

144collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =

145 let

146− declToInfo (Valid.Decl (A.A region name) _ _ _) =

146+ declToInfo (A.A _ (Valid.Decl (A.A region name) _ _ _)) =

147 Dups.info name region () ()

148

149 portToInfo (Valid.Port (A.A region name) _) =

@@ -266,7 +266,7 @@ addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result Env.Env

266addTypeAlias env@(Env.Env home vars types patterns binops) scc =

267 case scc of

268 Graph.AcyclicSCC (Alias _ name args tipe) ->

269− do (A.A _ ctype) <- Type.canonicalize env tipe

269+ do ctype <- Type.canonicalize env tipe

270 let info = (Env.Alias home args ctype, length args)

271 let newTypes = Map.alter (addAliasInfo info) name types

272 return $ Env.Env home vars newTypes patterns binops

@@ -315,13 +315,17 @@ getEdges (A.A _ tipe) =

315 foldr Bag.append Bag.empty (map getEdges args)

316

317 Type.RRecord fields ext ->

318+ foldr Bag.append

318− foldr Bag.append (maybe Bag.empty getEdges ext) (map (getEdges . snd) fields)

319+ (maybe Bag.empty getEdges ext)

320+ (map (getEdges . snd) fields)

319

321

320 Type.RUnit ->

322 Type.RUnit ->

321 Bag.empty

323 Bag.empty

322

324

323 Type.RTuple a b cs ->

325 Type.RTuple a b cs ->

326+ foldr Bag.append

327+ (getEdges a)

324− foldr Bag.append (getEdges a) (getEdges b : map getEdges cs)

328+ (getEdges b : map getEdges cs)

325

329

326

330

327

331

src/Canonicalize/Expression.hs+2−1

@@ -1,6 +1,7 @@

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize.Expression

3 ( canonicalize

4+ , removeLocals

4 )

5 )

5 where

6 where

@@ -358,7 +359,7 @@ detectCycles region sccs body =

358 Graph.CyclicSCC nodes ->

359 Graph.CyclicSCC nodes ->

359 case unzip <$> traverse requireDefine nodes of

360 case unzip <$> traverse requireDefine nodes of

360 Nothing ->

361 Nothing ->

361− Result.throw region (Error.RecursiveValue (map toCycleNodes nodes))

362+ Result.throw region (Error.RecursiveLet (map toCycleNodes nodes))

362

363

363 Just (defs, freeLocals) ->

364 Just (defs, freeLocals) ->

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

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

src/Canonicalize/Module.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Module

3+ ( canonicalize

4+ )

5+ where

8+import qualified Data.Graph as Graph

9+import qualified Data.Map as Map

10+import qualified Data.Set as Set

11+

12+import qualified AST.Expression.Canonical as Can

13+import qualified AST.Expression.Valid as Valid

14+import qualified AST.Module.Name as ModuleName

15+import qualified AST.Type as Type

16+import qualified Canonicalize.Environment as Env

17+import qualified Canonicalize.Expression as Expr

18+import qualified Canonicalize.Pattern as Pattern

19+import qualified Canonicalize.Type as Type

20+import qualified Elm.Interface as I

21+import qualified Elm.Name as N

22+import qualified Elm.Package as Pkg

23+import qualified Reporting.Annotation as A

24+import qualified Reporting.Error.Canonicalize as Error

25+import qualified Reporting.Region as R

26+import qualified Reporting.Result as Result

27+import qualified Reporting.Warning as Warning

28+

29+

30+

31+-- RESULT

32+

33+

34+type Result a =

35+ Result.Result () Warning.Warning Error.Error a

36+

37+

38+

39+-- MODULES

40+

41+

42+canonicalize

43+ :: Pkg.Name

44+ -> Map.Map ModuleName.Raw ModuleName.Canonical

45+ -> I.Interfaces

46+ -> Valid.Module

47+ -> Result Can.Module

48+canonicalize pkg importDict interfaces module_ =

49+ do env <- Env.create pkg importDict interfaces module_

50+ let (Valid.Module name _ _ _ _ decls unions aliases binops _) = module_

51+ Can.Module (ModuleName.Canonical pkg name)

52+ <$> error "TODO docs"

53+ <*> error "TODO imports"

54+ <*> canonicalizeDecls env decls

55+ <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)

56+ <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)

57+ <*> return (Map.fromList (map canonicalizeBinop binops))

58+ <*> error "TODO effects"

59+

60+

61+

62+-- CANONICALIZE ALIAS

63+

64+

65+canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )

66+canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =

67+ do ctipe <- Type.canonicalize env tipe

68+ return (name, Can.Alias (map A.drop args) ctipe)

69+

70+

71+

72+-- CANONICALIZE UNION

73+

74+

75+canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )

76+canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =

77+ let

78+ canonicalizeCtor (A.A _ ctor, tipes) =

79+ do ctipes <- traverse (Type.canonicalize env) tipes

80+ return (ctor, ctipes)

81+ in

82+ do cctors <- traverse canonicalizeCtor ctors

83+ return ( name, Can.Union (map A.drop args) cctors )

84+

85+

86+

87+-- CANONICALIZE BINOP

88+

89+

90+canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )

91+canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =

92+ ( op, Can.Binop_ associativity precedence func )

93+

94+

95+

96+-- CANONICALIZE DECLARATIONS

97+

98+

99+canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls

100+canonicalizeDecls env decls =

101+ do nodes <- traverse (toNode env) decls

102+ detectCycles (Graph.stronglyConnComp nodes)

103+

104+

105+detectCycles :: [Graph.SCC Decl] -> Result Can.Decls

106+detectCycles sccs =

107+ case sccs of

108+ [] ->

109+ Result.ok Can.SaveTheEnvironment

110+

111+ scc : otherSccs ->

112+ case scc of

113+ Graph.AcyclicSCC decl ->

114+ Can.Declare (toCanDecl decl)

115+ <$> detectCycles otherSccs

116+

117+ Graph.CyclicSCC [] ->

118+ detectCycles otherSccs

119+

120+ Graph.CyclicSCC (decl:decls) ->

121+ do detectBadCycles decl decls

122+ Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)

123+ <$> detectCycles otherSccs

124+

125+

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

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

128+ case args of

129+ [] ->

130+ do ctipe <- traverse (Type.canonicalize env) tipe

131+ (cbody, freeLocals) <- Expr.removeLocals Map.empty $ Expr.canonicalize env body

132+ return (Value region name cbody ctipe, key, Set.toList freeLocals)

133+

134+ _ ->

135+ do ctipe <- traverse (Type.canonicalize env) tipe

136+ cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args

137+ newEnv <- Env.addLocals destructors env

138+ (cbody, freeLocals) <- Expr.removeLocals destructors $ Expr.canonicalize newEnv body

139+ return (Function key cargs cbody ctipe, key, Set.toList freeLocals)

140+

141+

142+data Decl

143+ = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)

144+ | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)

145+

146+

147+toCanDecl :: Decl -> Can.Decl

148+toCanDecl decl =

149+ case decl of

150+ Value _ (A.A _ name) body tipe ->

151+ Can.Value name body tipe

152+

153+ Function name args body tipe ->

154+ Can.Function name args body tipe

155+

156+

157+detectBadCycles :: Decl -> [Decl] -> Result ()

158+detectBadCycles decl decls =

159+ case traverse detectBadCyclesHelp (decl:decls) of

160+ Nothing ->

161+ Result.ok ()

162+

163+ Just valueCycle ->

164+ case valueCycle of

165+ [] ->

166+ Result.ok ()

167+

168+ (declRegion, A.A region name) : otherInfo ->

169+ let otherNames = map (A.drop . snd) otherInfo in

170+ Result.throw declRegion (Error.RecursiveDecl region name otherNames)

171+

172+

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

174+detectBadCyclesHelp decl =

175+ case decl of

176+ Value region name _ _ ->

177+ Just (region, name)

178+

179+ Function _ _ _ _ ->

180+ Nothing

src/Canonicalize/Type.hs+10−15

@@ -29,20 +29,15 @@ type Result i a =

29-- CANONICALIZE TYPES

32−canonicalize :: Env.Env -> Type.Raw -> Result () (A.Located Type.Canonical)

32+canonicalize :: Env.Env -> Type.Raw -> Result () Type.Canonical

33−canonicalize env tipe@(A.A region _) =

33+canonicalize env (A.A _ tipe) =

34− A.A region <$> canonicalizeHelp env tipe

35−

36−

37−canonicalizeHelp :: Env.Env -> Type.Raw -> Result () Type.Canonical

38−canonicalizeHelp env (A.A _ tipe) =

39 case tipe of

34 case tipe of

40 Type.RVar x ->

35 Type.RVar x ->

41 Result.ok (Type.Var x)

36 Result.ok (Type.Var x)

43 Type.RType region maybePrefix name args ->

38 Type.RType region maybePrefix name args ->

44 do info <- Env.findType region env maybePrefix name (length args)

39 do info <- Env.findType region env maybePrefix name (length args)

45− cargs <- traverse (canonicalizeHelp env) args

40+ cargs <- traverse (canonicalize env) args

46 return $

41 return $

47 case info of

42 case info of

48 Env.Alias home argNames aliasedType ->

43 Env.Alias home argNames aliasedType ->

@@ -53,20 +48,20 @@ canonicalizeHelp env (A.A _ tipe) =

54 Type.RLambda a b ->

49 Type.RLambda a b ->

55 Type.Lambda

50 Type.Lambda

56− <$> canonicalizeHelp env a

51+ <$> canonicalize env a

57− <*> canonicalizeHelp env b

52+ <*> canonicalize env b

59 Type.RRecord fields ext ->

54 Type.RRecord fields ext ->

60 do fieldDict <- Dups.checkFields fields

55 do fieldDict <- Dups.checkFields fields

61 Type.Record

56 Type.Record

62− <$> Map.traverseWithKey (\_ t -> canonicalizeHelp env t) fieldDict

57+ <$> Map.traverseWithKey (\_ t -> canonicalize env t) fieldDict

63− <*> traverse (canonicalizeHelp env) ext

58+ <*> traverse (canonicalize env) ext

65 Type.RUnit ->

60 Type.RUnit ->

66 Result.ok Type.Unit

61 Result.ok Type.Unit

68 Type.RTuple a b cs ->

63 Type.RTuple a b cs ->

69 Type.Tuple

64 Type.Tuple

70− <$> canonicalizeHelp env a

65+ <$> canonicalize env a

71− <*> canonicalizeHelp env b

66+ <*> canonicalize env b

72− <*> traverse (canonicalizeHelp env) cs

67+ <*> traverse (canonicalize env) cs

src/Validate.hs+9−8

@@ -43,7 +43,7 @@ validate (Src.Module name srcEffects overview exports imports srcDecls) =

44data Stuff =

45 Stuff

46− { _decls :: [Valid.Decl]

46+ { _decls :: [A.Located Valid.Decl]

47 , _unions :: [Valid.Union]

48 , _aliases :: [Valid.Alias]

49 , _binops :: [Valid.Binop]

@@ -63,7 +63,7 @@ vsdHelp decls stuff =

63 [] ->

64 Result.ok stuff

66− A.A _ decl : otherDecls ->

66+ A.A region decl : otherDecls ->

67 case decl of

68 Src.Union name tvars ctors ->

69 do let union = Valid.Union name tvars ctors

@@ -85,11 +85,11 @@ vsdHelp decls stuff =

85 validateDocs docs otherDecls stuff

87 Src.Annotation (A.A _ name) tipe ->

88− validateAnnotation name tipe otherDecls stuff

88+ validateAnnotation region name tipe otherDecls stuff

90 Src.Definition name args body ->

91 do validBody <- expression body

92− let validDecl = Valid.Decl name args validBody Nothing

92+ let validDecl = A.A region (Valid.Decl name args validBody Nothing)

93 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }

@@ -137,18 +137,19 @@ getNameForDocs decl =

137-- VALIDATE ANNOTATION

138

139

140−validateAnnotation :: N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff

140+validateAnnotation :: R.Region -> N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff

141−validateAnnotation annotationName tipe decls stuff =

141+validateAnnotation annRegion annotationName tipe decls stuff =

142 case decls of

143 [] ->

144 error "TODO no attotations on nothing"

145

146− A.A _ decl : otherDecls ->

146+ A.A defRegion decl : otherDecls ->

147 case decl of

148 Src.Definition name@(A.A _ definitionName) args body ->

149 if annotationName == definitionName then

150 do validBody <- expression body

151+ let region = R.merge annRegion defRegion

151− let validDecl = Valid.Decl name args validBody (Just tipe)

152+ let validDecl = A.A region (Valid.Decl name args validBody (Just tipe))

152 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }

153 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }

153

154

154 else

155 else