bfb8eca · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get a decent chunk of expression canonicalization compiling

bfb8ecaEvan Czaplicki9 years ago

src/Canonicalize/Environment.hs+16−1

compare with master

unifiedsplit

@@ -4,6 +4,7 @@ module Canonicalize.Environment

4 ( Env.Result

5 , Env.Env

6 , create

7+ , Env.addLocals

7 , Env.findVar

8 , Env.findVar

8 , Env.findType

9 , Env.findType

9 , Env.findPattern

10 , Env.findPattern

@@ -23,14 +24,28 @@ import qualified Canonicalize.Environment.Internals as Env

23import qualified Canonicalize.Environment.Local as Local

24import qualified Canonicalize.Environment.Local as Local

24import qualified Elm.Interface as I

25import qualified Elm.Interface as I

25import qualified Elm.Package as Package

26import qualified Elm.Package as Package

27+import qualified Reporting.Error.Canonicalize as Error

28+import qualified Reporting.Result as Result

29+import qualified Reporting.Warning as Warning

33+-- RESULT

34+

35+

36+type Result a =

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

38+

39+

40+

41+-- CREATE

42+

43+

29type ImportDict =

44type ImportDict =

30 Map.Map ModuleName.Raw ModuleName.Canonical

45 Map.Map ModuleName.Raw ModuleName.Canonical

33−create :: Package.Name -> ImportDict -> I.Interfaces -> Valid.Module -> Env.Result Env.Env

48+create :: Package.Name -> ImportDict -> I.Interfaces -> Valid.Module -> Result Env.Env

34create pkg importDict interfaces module_@(Valid.Module name _ _ _ imports _ _ _ _ _) =

49create pkg importDict interfaces module_@(Valid.Module name _ _ _ imports _ _ _ _ _) =

35 let home = ModuleName.Canonical pkg name in

50 let home = ModuleName.Canonical pkg name in

36 Local.addDeclarations module_ =<<

51 Local.addDeclarations module_ =<<

src/Canonicalize/Environment/Dups.hs+4−4

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

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Canonicalize.Environment.Dups

4− ( Info

4+ ( Info(Info)

5 , info

6 , detect

7 , checkFields

@@ -45,12 +45,12 @@ type ToError c =

45 N.Name -> c -> c -> Error.Error

48−detect :: ToError c -> [(N.Name, [Info c v])] -> Result (Map.Map N.Name v)

48+detect :: ToError c -> [(N.Name, [Info c v])] -> Result () (Map.Map N.Name v)

49detect toError pairs =

50 Map.traverseWithKey (detectHelp toError) $ Map.fromListWith (++) pairs

53−detectHelp :: ToError c -> N.Name -> [Info c v] -> Result v

53+detectHelp :: ToError c -> N.Name -> [Info c v] -> Result () v

54detectHelp toError name values =

55 case values of

56 [Info _ _ value] ->

@@ -67,7 +67,7 @@ detectHelp toError name values =

67-- CHECK FIELDS

70−checkFields :: [(A.Located N.Name, a)] -> Result (Map.Map N.Name a)

70+checkFields :: [(A.Located N.Name, a)] -> Result () (Map.Map N.Name a)

71checkFields fields =

72 let

73 toInfo (A.A region name, value) =

src/Canonicalize/Environment/Foreign.hs+18−9

@@ -12,9 +12,9 @@ import qualified Data.Set as Set

12import qualified AST.Expression.Canonical as Can

13import qualified AST.Expression.Source as Src

14import qualified AST.Module.Name as ModuleName

15−import qualified Canonicalize.Bag as Bag

16import qualified Canonicalize.Environment.Internals as Env

15import qualified Canonicalize.Environment.Internals as Env

16+import qualified Data.Bag as Bag

17−import qualified Canonicalize.OneOrMore as OneOrMore

17+import qualified Data.OneOrMore as OneOrMore

18import qualified Elm.Interface as I

19import qualified Elm.Name as N

20import qualified Reporting.Annotation as A

@@ -22,6 +22,15 @@ import qualified Reporting.Error.Canonicalize as Error

22import qualified Reporting.Helpers as Help (nearbyNames)

23import qualified Reporting.Region as R

24import qualified Reporting.Result as Result

25+import qualified Reporting.Warning as Warning

26+

27+

28+

29+-- RESULT

30+

31+

32+type Result a =

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

@@ -70,7 +79,7 @@ type ImportDict =

70 Map.Map ModuleName.Raw ModuleName.Canonical

79 Map.Map ModuleName.Raw ModuleName.Canonical

73−createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Env.Result Env.Env

82+createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result Env.Env

74createInitialEnv home importDict interfaces sourceImports =

83createInitialEnv home importDict interfaces sourceImports =

75 do imports <- traverse (verifyImport importDict interfaces) sourceImports

84 do imports <- traverse (verifyImport importDict interfaces) sourceImports

76 let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)

85 let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)

@@ -238,7 +247,7 @@ data Exposed

238 | Alias

247 | Alias

239

248

240

249

241−verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Env.Result Import

250+verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result Import

242verifyImport importDict interfaces (Src.Import (A.A region name) alias exposing) =

251verifyImport importDict interfaces (Src.Import (A.A region name) alias exposing) =

243 case Map.lookup name importDict of

252 case Map.lookup name importDict of

244 Nothing ->

253 Nothing ->

@@ -260,14 +269,14 @@ verifyImport importDict interfaces (Src.Import (A.A region name) alias exposing)

260 Result.ok (Explicit (Map.fromList (concat pairLists)))

269 Result.ok (Explicit (Map.fromList (concat pairLists)))

261

270

262

271

263−throwImportNotFound :: R.Region -> ModuleName.Raw -> [ModuleName.Canonical] -> Env.Result a

272+throwImportNotFound :: R.Region -> ModuleName.Raw -> [ModuleName.Canonical] -> Result a

264throwImportNotFound region name knownModules =

273throwImportNotFound region name knownModules =

265 Result.throw region $ Error.ImportNotFound name $

274 Result.throw region $ Error.ImportNotFound name $

266 Help.nearbyNames ModuleName.toString name $

275 Help.nearbyNames ModuleName.toString name $

267 map ModuleName._module knownModules

276 map ModuleName._module knownModules

268

277

269

278

270−verifyExposed :: ModuleName.Raw -> I.Interface -> A.Located Src.Exposed -> Env.Result [(N.Name, Exposed)]

279+verifyExposed :: ModuleName.Raw -> I.Interface -> A.Located Src.Exposed -> Result [(N.Name, Exposed)]

271verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A region exposed) =

280verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A region exposed) =

272 case exposed of

281 case exposed of

273 Src.Operator name ->

282 Src.Operator name ->

@@ -291,7 +300,7 @@ verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A regio

291 throwExposingNotFound moduleName region name interface

300 throwExposingNotFound moduleName region name interface

292

301

293

302

294−verifyValue :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Env.Result [(N.Name, Exposed)]

303+verifyValue :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Result [(N.Name, Exposed)]

295verifyValue moduleName region name interface@(I.Interface _ types _ _ _) =

304verifyValue moduleName region name interface@(I.Interface _ types _ _ _) =

296 case Map.lookup name types of

305 case Map.lookup name types of

297 Nothing ->

306 Nothing ->

@@ -301,7 +310,7 @@ verifyValue moduleName region name interface@(I.Interface _ types _ _ _) =

301 Result.ok [(name, Value)]

310 Result.ok [(name, Value)]

302

311

303

312

304−verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Env.Result [(N.Name, Exposed)]

313+verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Result [(N.Name, Exposed)]

305verifyAlias region name privacy =

314verifyAlias region name privacy =

306 case privacy of

315 case privacy of

307 Src.Public ->

316 Src.Public ->

@@ -311,7 +320,7 @@ verifyAlias region name privacy =

311 Result.ok [(name, Alias)]

320 Result.ok [(name, Alias)]

312

321

313

322

314−throwExposingNotFound :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Env.Result a

323+throwExposingNotFound :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Result a

315throwExposingNotFound moduleName region name (I.Interface _ types unions aliases _) =

324throwExposingNotFound moduleName region name (I.Interface _ types unions aliases _) =

316 let

325 let

317 toCtorPairs (tipe, Can.Union _ ctors) =

326 toCtorPairs (tipe, Can.Union _ ctors) =

src/Canonicalize/Environment/Internals.hs+49−10

@@ -7,6 +7,7 @@ module Canonicalize.Environment.Internals

7 , UnqualifiedVarHome(..)

8 , Type(..)

9 , Homes(..)

10+ , addLocals

10 , findVar

11 , findVar

11 , findType

12 , findType

12 , findPattern

13 , findPattern

@@ -17,14 +18,17 @@ module Canonicalize.Environment.Internals

19import qualified Data.Map.Strict as Map

20import qualified Data.Map.Strict as Map

21+import qualified Data.Map.Merge.Strict as Map

22+import qualified Data.Set as Set

21import qualified AST.Binop as Binop

24import qualified AST.Binop as Binop

22import qualified AST.Expression.Canonical as Can

25import qualified AST.Expression.Canonical as Can

23import qualified AST.Module.Name as ModuleName

26import qualified AST.Module.Name as ModuleName

24import qualified AST.Type as Type

27import qualified AST.Type as Type

25−import qualified Canonicalize.Bag as Bag

28+import qualified Data.Bag as Bag

26−import qualified Canonicalize.OneOrMore as OneOrMore

29+import qualified Data.OneOrMore as OneOrMore

27import qualified Elm.Name as N

30import qualified Elm.Name as N

31+import qualified Reporting.Annotation as A

28import qualified Reporting.Error.Canonicalize as Error

32import qualified Reporting.Error.Canonicalize as Error

29import qualified Reporting.Region as R

33import qualified Reporting.Region as R

30import qualified Reporting.Result as Result

34import qualified Reporting.Result as Result

@@ -35,8 +39,8 @@ import qualified Reporting.Warning as Warning

35-- RESULT HELPERS

39-- RESULT HELPERS

38−type Result a =

42+type Result i a =

39− Result.Result () Warning.Warning Error.Error a

43+ Result.Result i Warning.Warning Error.Error a

@@ -88,10 +92,45 @@ data Binop =

95+-- ADD LOCALS

96+

97+

98+addLocals :: Map.Map N.Name (A.Located a) -> Env -> Result () Env

99+addLocals names (Env home vars types patterns binops) =

100+ do newVars <-

101+ Map.mergeA

102+ (Map.mapMissing (\_ _ -> localVarHomes))

103+ (Map.mapMissing (\_ homes -> homes))

104+ (Map.zipWithAMatched addLocalBoth)

105+ names

106+ vars

107+ Result.ok $ Env home newVars types patterns binops

108+

109+

110+{-# NOINLINE localVarHomes #-}

111+localVarHomes :: VarHomes

112+localVarHomes =

113+ VarHomes Local Map.empty

114+

115+

116+addLocalBoth :: N.Name -> A.Located a -> VarHomes -> Result () VarHomes

117+addLocalBoth name (A.A region _) (VarHomes unqualified qualified) =

118+ case unqualified of

119+ Foreign _ ->

120+ Result.ok (VarHomes Local qualified)

121+

122+ Local ->

123+ Result.throw region (Error.Shadowing name)

124+

125+ TopLevel ->

126+ Result.throw region (Error.Shadowing name)

127+

128+

129+

91-- FIND VAR

130-- FIND VAR

131

132

94−findVar :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result Can.Expr_

133+findVar :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result (Set.Set N.Name) Can.Expr_

95findVar region (Env home vars _ _ _) maybePrefix name =

134findVar region (Env home vars _ _ _) maybePrefix name =

96 case Map.lookup name vars of

135 case Map.lookup name vars of

97 Nothing ->

136 Nothing ->

@@ -102,10 +141,10 @@ findVar region (Env home vars _ _ _) maybePrefix name =

102 Nothing ->

141 Nothing ->

103 case unqualified of

142 case unqualified of

104 Local ->

143 Local ->

105− Result.ok (Can.VarLocal name)

144+ Result.accumulate (Set.singleton name) (Can.VarLocal name)

106

145

107 TopLevel ->

146 TopLevel ->

108− Result.ok (Can.VarTopLevel home name)

147+ Result.accumulate (Set.singleton name) (Can.VarTopLevel home name)

109

148

110 Foreign bag ->

149 Foreign bag ->

111 case bag of

150 case bag of

@@ -134,12 +173,12 @@ findVar region (Env home vars _ _ _) maybePrefix name =

134-- FIND TYPE and PATTERN

173-- FIND TYPE and PATTERN

135

174

136

175

137−findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result Type

176+findType :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i Type

138findType region (Env _ _ types _ _) maybePrefix name arity =

177findType region (Env _ _ types _ _) maybePrefix name arity =

139 error "TODO findType" region types maybePrefix name arity

178 error "TODO findType" region types maybePrefix name arity

140

179

141

180

142−findPattern :: R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result ModuleName.Canonical

181+findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i ModuleName.Canonical

143findPattern region (Env _ _ _ patterns _) maybePrefix name arity =

182findPattern region (Env _ _ _ patterns _) maybePrefix name arity =

144 error "TODO findPattern" region patterns maybePrefix name arity

183 error "TODO findPattern" region patterns maybePrefix name arity

145

184

@@ -148,7 +187,7 @@ findPattern region (Env _ _ _ patterns _) maybePrefix name arity =

148-- FIND BINOP

187-- FIND BINOP

149

188

150

189

151−findBinop :: R.Region -> Env -> N.Name -> Result Binop

190+findBinop :: R.Region -> Env -> N.Name -> Result (Set.Set N.Name) Binop

152findBinop region (Env _ _ _ _ binops) name =

191findBinop region (Env _ _ _ _ binops) name =

153 case Map.lookup name binops of

192 case Map.lookup name binops of

154 Just (OneOrMore.One binop) ->

193 Just (OneOrMore.One binop) ->

src/Canonicalize/Environment/Local.hs+23−14

@@ -14,23 +14,32 @@ import qualified Data.Map.Merge.Strict as Map

15import qualified AST.Expression.Valid as Valid

16import qualified AST.Type as Type

17−import qualified Canonicalize.Bag as Bag

18import qualified Canonicalize.Environment.Dups as Dups

17import qualified Canonicalize.Environment.Dups as Dups

19import qualified Canonicalize.Environment.Internals as Env

18import qualified Canonicalize.Environment.Internals as Env

20−import qualified Canonicalize.OneOrMore as OneOrMore

21import qualified Canonicalize.Type as Type

19import qualified Canonicalize.Type as Type

20+import qualified Data.Bag as Bag

21+import qualified Data.OneOrMore as OneOrMore

22import qualified Elm.Name as N

23import qualified Reporting.Annotation as A

24import qualified Reporting.Error.Canonicalize as Error

25import qualified Reporting.Region as R

26import 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

30-- ADD DECLARATIONS

39-- ADD DECLARATIONS

33−addDeclarations :: Valid.Module -> Env.Env -> Env.Result Env.Env

42+addDeclarations :: Valid.Module -> Env.Env -> Result Env.Env

34addDeclarations module_ env =

43addDeclarations module_ env =

35 addVars module_

44 addVars module_

36 =<< addTypes module_

45 =<< addTypes module_

@@ -89,7 +98,7 @@ addPatterns (Valid.Module _ _ _ _ _ _ unions _ _ _) (Env.Env home vars types pat

89-- ADD BINOPS

98-- ADD BINOPS

100

92−addBinops :: Valid.Module -> Env.Env -> Env.Result Env.Env

101+addBinops :: Valid.Module -> Env.Env -> Result Env.Env

93addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =

102addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =

94 let

103 let

95 toInfo (Valid.Binop (A.A region op) assoc prec name) =

104 toInfo (Valid.Binop (A.A region op) assoc prec name) =

@@ -107,7 +116,7 @@ addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns

107-- ADD VARS

116-- ADD VARS

108

117

109

118

110−addVars :: Valid.Module -> Env.Env -> Env.Result Env.Env

119+addVars :: Valid.Module -> Env.Env -> Result Env.Env

111addVars module_ (Env.Env home vars types patterns binops) =

120addVars module_ (Env.Env home vars types patterns binops) =

112 do upperDict <- collectUpperVars module_

121 do upperDict <- collectUpperVars module_

113 lowerDict <- collectLowerVars module_

122 lowerDict <- collectLowerVars module_

@@ -131,7 +140,7 @@ addVarsHelp localVars vars =

131 merge addLeft addBoth localVars vars

140 merge addLeft addBoth localVars vars

132

141

133

142

134−collectLowerVars :: Valid.Module -> Env.Result (Map.Map N.Name ())

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

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

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

136 let

145 let

137 declToInfo (Valid.Decl (A.A region name) _ _ _) =

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

@@ -166,7 +175,7 @@ collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =

166 effectInfo ++ map declToInfo decls

175 effectInfo ++ map declToInfo decls

167

176

168

177

169−collectUpperVars :: Valid.Module -> Env.Result (Map.Map N.Name ())

178+collectUpperVars :: Valid.Module -> Result (Map.Map N.Name ())

170collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =

179collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =

171 let

180 let

172 unionToInfos (Valid.Union (A.A _ name) _ ctors) =

181 unionToInfos (Valid.Union (A.A _ name) _ ctors) =

@@ -191,7 +200,7 @@ collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =

191-- ADD TYPES

200-- ADD TYPES

192

201

193

202

194−addTypes :: Valid.Module -> Env.Env -> Env.Result Env.Env

203+addTypes :: Valid.Module -> Env.Env -> Result Env.Env

195addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =

204addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =

196 let

205 let

197 aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =

206 aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =

@@ -246,18 +255,18 @@ data Alias =

246 }

255 }

247

256

248

257

249−addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Env.Result Env.Env

258+addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result Env.Env

250addTypeAliases aliases env =

259addTypeAliases aliases env =

251 do let nodes = map toNode (Map.elems aliases)

260 do let nodes = map toNode (Map.elems aliases)

252 let sccs = Graph.stronglyConnComp nodes

261 let sccs = Graph.stronglyConnComp nodes

253 foldM addTypeAlias env sccs

262 foldM addTypeAlias env sccs

254

263

255

264

256−addTypeAlias :: Env.Env -> Graph.SCC Alias -> Env.Result Env.Env

265+addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result Env.Env

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

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

258 case scc of

267 case scc of

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

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

260− do ctype <- Type.canonicalize env tipe

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

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

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

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

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

263 return $ Env.Env home vars newTypes patterns binops

272 return $ Env.Env home vars newTypes patterns binops

@@ -267,7 +276,7 @@ addTypeAlias env@(Env.Env home vars types patterns binops) scc =

267

276

268 Graph.CyclicSCC (Alias region name1 args tipe : others) ->

277 Graph.CyclicSCC (Alias region name1 args tipe : others) ->

269 let toName (Alias _ name _ _) = name in

278 let toName (Alias _ name _ _) = name in

270− Result.throw region (Error.AliasRecursion name1 args tipe (map toName others))

279+ Result.throw region (Error.RecursiveAlias name1 args tipe (map toName others))

271

280

272

281

273addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)

282addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)

@@ -319,7 +328,7 @@ getEdges (A.A _ tipe) =

319-- CHECK FREE VARIABLES

328-- CHECK FREE VARIABLES

320

329

321

330

322−checkUnionFreeVars :: Valid.Union -> Env.Result Int

331+checkUnionFreeVars :: Valid.Union -> Result Int

323checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

332checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

324 let

333 let

325 toInfo (A.A region arg) =

334 toInfo (A.A region arg) =

@@ -344,7 +353,7 @@ checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

344

353

345

354

346

355

347−checkAliasFreeVars :: Valid.Alias -> Env.Result [N.Name]

356+checkAliasFreeVars :: Valid.Alias -> Result [N.Name]

348checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =

357checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =

349 let

358 let

350 toInfo (A.A region arg) =

359 toInfo (A.A region arg) =

src/Canonicalize/Expression.hsnew file+295

@@ -0,0 +1,295 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Expression

3+ ( canonicalize

4+ )

5+ where

8+import Control.Applicative (liftA2)

9+import qualified Data.Graph as Graph

10+import qualified Data.Map.Strict as Map

11+import qualified Data.Set as Set

12+

13+import qualified AST.Expression.Canonical as Can

14+import qualified AST.Expression.Valid as Valid

15+import qualified Canonicalize.Environment as Env

16+import qualified Canonicalize.Environment.Dups as Dups

17+import qualified Canonicalize.Pattern as Pattern

18+import qualified Canonicalize.Type as Type

19+import qualified Elm.Name as N

20+import qualified Reporting.Annotation as A

21+import qualified Reporting.Error.Canonicalize as Error

22+import qualified Reporting.Region as R

23+import qualified Reporting.Result as Result

24+import qualified Reporting.Warning as Warning

25+

26+

27+

28+-- RESULTS

29+

30+

31+type Result i a =

32+ Result.Result i Warning.Warning Error.Error a

33+

34+

35+type FreeLocals =

36+ Set.Set N.Name

37+

38+

39+

40+-- EXPRESSIONS

41+

42+

43+canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals Can.Expr

44+canonicalize env (A.A region expression) =

45+ A.A region <$>

46+ case expression of

47+ Valid.Literal lit ->

48+ Result.ok (Can.Literal lit)

49+

50+ Valid.Var maybePrefix name ->

51+ Env.findVar region env maybePrefix name

52+

53+ Valid.List exprs ->

54+ Can.List <$> traverse (canonicalize env) exprs

55+

56+ Valid.Op name ->

57+ do (Env.Binop home func _ _) <- Env.findBinop region env name

58+ return (Can.VarOperator name home func)

59+

60+ Valid.Negate expr ->

61+ Can.Negate <$> canonicalize env expr

62+

63+ Valid.Binops ops final ->

64+ error "TODO"

65+

66+ Valid.Lambda args body ->

67+ addLocals $

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

69+ newEnv <- Env.addLocals destructors env

70+ removeLocals destructors $

71+ Can.Lambda cargs <$> canonicalize newEnv body

72+

73+ Valid.Call func args ->

74+ Can.Call

75+ <$> canonicalize env func

76+ <*> traverse (canonicalize env) args

77+

78+ Valid.If branches finally ->

79+ Can.If

80+ <$> traverse (canonicalizeBranch env) branches

81+ <*> canonicalize env finally

82+

83+ Valid.Let defs expr ->

84+ A.drop <$> canonicalizeLet region env defs expr

85+

86+ Valid.Case expr cases ->

87+ error "TODO"

88+

89+ Valid.Accessor field ->

90+ Result.ok $ Can.Accessor field

91+

92+ Valid.Access record field ->

93+ Can.Access

94+ <$> canonicalize env record

95+ <*> Result.ok field

96+

97+ Valid.Update (A.A reg name) fields ->

98+ do fieldDict <- Result.untracked $ Dups.checkFields fields

99+ name_ <- Env.findVar reg env Nothing name

100+ Can.Update (A.A reg name_)

101+ <$> traverse (canonicalize env) fieldDict

102+

103+ Valid.Record fields ->

104+ do fieldDict <- Result.untracked $ Dups.checkFields fields

105+ Can.Record <$> traverse (canonicalize env) fieldDict

106+

107+ Valid.Unit ->

108+ Result.ok Can.Unit

109+

110+ Valid.Tuple a b cs ->

111+ Can.Tuple

112+ <$> canonicalize env a

113+ <*> canonicalize env b

114+ <*> canonicalizeTupleExtras region env cs

115+

116+ Valid.GLShader uid src tipe ->

117+ Result.ok (Can.GLShader uid src tipe)

118+

119+

120+

121+-- CANONICALIZE TUPLE EXTRAS

122+

123+

124+canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals (Maybe Can.Expr)

125+canonicalizeTupleExtras region env extras =

126+ case extras of

127+ [] ->

128+ Result.ok Nothing

129+

130+ [three] ->

131+ Just <$> canonicalize env three

132+

133+ _ : others ->

134+ let (A.A r1 _, A.A r2 _) = (head others, last others) in

135+ Result.throw region (Error.TupleLargerThanThree (R.merge r1 r2))

136+

137+

138+

139+-- CANONICALIZE IF BRANCH

140+

141+

142+canonicalizeBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals (Can.Expr, Can.Expr)

143+canonicalizeBranch env (condition, branch) =

144+ liftA2 (,) (canonicalize env condition) (canonicalize env branch)

145+

146+

147+

148+-- CANONICALIZE LET

149+

150+

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

152+canonicalizeLet region env defs body =

153+ addLocals $

154+ do (bindings, boundNames) <- Pattern.canonicalizeBindings env defs

155+ newEnv <- Env.addLocals boundNames env

156+ let defKeys = Map.map A.drop boundNames

157+ nodes <- Result.untracked $ traverse (bindingToNode defKeys newEnv) bindings

158+ removeLocals defKeys $

159+ do cbody <- canonicalize env body

160+ detectCycles region (Graph.stronglyConnComp nodes) cbody

161+

162+

163+addLocals :: Result () (expr, FreeLocals) -> Result FreeLocals expr

164+addLocals (Result.Result () warnings answer) =

165+ case answer of

166+ Result.Ok (value, freeLocals) ->

167+ Result.Result freeLocals warnings (Result.Ok value)

168+

169+ Result.Err err ->

170+ Result.Result Set.empty warnings (Result.Err err)

171+

172+

173+removeLocals :: Map.Map N.Name a -> Result FreeLocals expr -> Result () (expr, FreeLocals)

174+removeLocals boundNames (Result.Result freeLocals warnings answer) =

175+ Result.Result () warnings $

176+ case answer of

177+ Result.Ok value ->

178+ Result.Ok

179+ ( value

180+ , Set.difference freeLocals (Map.keysSet boundNames)

181+ )

182+

183+ Result.Err err ->

184+ Result.Err err

185+

186+

187+

188+-- BUILD BINDINGS GRAPH

189+

190+

191+data Binding

192+ = Define R.Region Can.Def

193+ | Destruct R.Region Can.Match Can.Expr

194+

195+

196+data Node = Node Binding FreeLocals

197+

198+

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

200+bindingToNode defKeys env binding =

201+ case binding of

202+ Pattern.Define region index name args body maybeType ->

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

204+ ctype <- traverse (Type.canonicalize env) maybeType

205+ newEnv <- Env.addLocals destructors env

206+ toNode defKeys destructors index $

207+ do cbody <- canonicalize newEnv body

208+ return (Define region (Can.Def name cargs cbody ctype))

209+

210+ Pattern.Destruct region index match body ->

211+ toNode defKeys Map.empty index $

212+ Destruct region match <$> canonicalize env body

213+

214+

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

216+toNode defKeys args index (Result.Result freeLocals warnings answer) =

217+ Result.Result () warnings $

218+ case answer of

219+ Result.Err err ->

220+ Result.Err err

221+

222+ Result.Ok binding ->

223+ let

224+ actuallyFreeLocals = Set.difference freeLocals (Map.keysSet args)

225+ locallyDefinedLocals = Map.restrictKeys defKeys freeLocals

226+ in

227+ Result.Ok

228+ ( Node binding actuallyFreeLocals

229+ , index

230+ , Map.elems locallyDefinedLocals

231+ )

232+

233+

234+

235+-- DETECT CYCLES

236+

237+

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

239+detectCycles region sccs body =

240+ case sccs of

241+ [] ->

242+ Result.ok body

243+

244+ scc : subSccs ->

245+ A.A region <$>

246+ case scc of

247+ Graph.AcyclicSCC (Node binding freeLocals) ->

248+ case binding of

249+ Define _ def ->

250+ Result.accumulate freeLocals (Can.Let def)

251+ <*> detectCycles region subSccs body

252+

253+ Destruct _ match expr ->

254+ Result.accumulate freeLocals (Can.LetDestruct match expr)

255+ <*> detectCycles region subSccs body

256+

257+ Graph.CyclicSCC nodes ->

258+ case unzip <$> traverse requireDefine nodes of

259+ Nothing ->

260+ Result.throw region (Error.RecursiveValue (map toCycleNodes nodes))

261+

262+ Just (defs, freeLocals) ->

263+ Result.accumulate (Set.unions freeLocals) (Can.LetRec defs)

264+ <*> detectCycles region subSccs body

265+

266+

267+

268+requireDefine :: Node -> Maybe (Can.Def, FreeLocals)

269+requireDefine (Node binding freeLocals) =

270+ case binding of

271+ Define _ def@(Can.Def _ (Can.Args args _) _ _) ->

272+ case args of

273+ [] ->

274+ Nothing

275+

276+ _ ->

277+ Just (def, freeLocals)

278+

279+ Destruct _ _ _ ->

280+ Nothing

281+

282+

283+toCycleNodes :: Node -> Error.CycleNode

284+toCycleNodes (Node binding _) =

285+ case binding of

286+ Define _ (Can.Def name (Can.Args args _) _ _) ->

287+ case args of

288+ [] ->

289+ Error.CycleValue name

290+

291+ _ ->

292+ Error.CycleFunc name

293+

294+ Destruct _ (Can.Match pattern _) _ ->

295+ Error.CyclePattern pattern

src/Canonicalize/Pattern.hsnew file+221

@@ -0,0 +1,221 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Pattern

3+ ( canonicalizeArgs

4+ , canonicalizeMatch

5+ , canonicalizeBindings

6+ , Binding(..)

7+ )

8+ where

10+

11+import Control.Monad (zipWithM)

12+import qualified Data.Map.Strict as Map

13+

14+import qualified AST.Expression.Canonical as Can

15+import qualified AST.Expression.Source as Src

16+import qualified AST.Expression.Valid as Valid

17+import qualified AST.Type as Type

18+import qualified Canonicalize.Environment as Env

19+import qualified Canonicalize.Environment.Dups as Dups

20+import qualified Data.Bag as Bag

21+import qualified Elm.Name as N

22+import qualified Reporting.Annotation as A

23+import qualified Reporting.Error.Canonicalize as Error

24+import qualified Reporting.Region as R

25+import qualified Reporting.Result as Result

26+import qualified Reporting.Warning as Warning

27+

28+

29+

30+-- RESULTS

31+

32+

33+type Result i =

34+ Result.Result i Warning.Warning Error.Error

35+

36+

37+

38+-- CANONICALIZE ARGS

39+

40+

41+canonicalizeArgs :: Env.Env -> [Src.Pattern] -> Result () Can.Args

42+canonicalizeArgs env patterns =

43+ case zipWithM (canonicalizeArg env) patterns [ 0 .. length patterns ] of

44+ Result.Result bag warnings (Result.Ok args) ->

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

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

47+ Result.Result () warnings $ Result.Ok $

48+ Can.Args args destructors

49+

50+ Result.Result _ warnings (Result.Err err) ->

51+ Result.Result () warnings (Result.Err err)

52+

53+

54+canonicalizeArg :: Env.Env -> Src.Pattern -> Int -> Result Bag Can.Arg

55+canonicalizeArg env pattern index =

56+ Can.Arg index <$> canonicalize env (Can.DRoot index) pattern

57+

58+

59+

60+-- CANONICALIZE MATCH

61+

62+

63+canonicalizeMatch :: Env.Env -> Src.Pattern -> Result () Can.Match

64+canonicalizeMatch env pattern =

65+ case canonicalize env (Can.DRoot 0) pattern of

66+ Result.Result bag warnings (Result.Ok cpattern) ->

67+ do let toError name () () = Error.DuplicateArg name

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

69+ Result.Result () warnings $ Result.Ok $

70+ Can.Match cpattern destructors

71+

72+ Result.Result _ warnings (Result.Err err) ->

73+ Result.Result () warnings (Result.Err err)

74+

75+

76+

77+-- CANONICALIZE BINDINGS

78+

79+

80+data Binding

81+ = Define R.Region Int (A.Located N.Name) [Src.Pattern] Valid.Expr (Maybe Type.Raw)

82+ | Destruct R.Region Int Can.Match Valid.Expr

83+

84+

85+canonicalizeBindings :: Env.Env -> [Valid.Def] -> Result () ( [Binding], Map.Map N.Name (A.Located Int) )

86+canonicalizeBindings env defs =

87+ case zipWithM (canonicalizeBinding env) defs [ 0 .. length defs ] of

88+ Result.Result bag warnings (Result.Ok cdefs) ->

89+ do let toError name () () = Error.DuplicateBindingName name

90+ nodes <- Dups.detect toError (Bag.toList bag)

91+ Result.Result () warnings (Result.Ok (cdefs, nodes))

92+

93+ Result.Result _ warnings (Result.Err err) ->

94+ Result.Result () warnings (Result.Err err)

95+

96+

97+type KeyBag =

98+ Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )

99+

100+

101+canonicalizeBinding :: Env.Env -> Valid.Def -> Int -> Result KeyBag Binding

102+canonicalizeBinding env def index =

103+ case def of

104+ Valid.Define region aname@(A.A reg name) args body maybeType ->

105+ let info = Dups.info name reg () (A.A region index) in

106+ Result.accumulate (Bag.one info) $

107+ Define region index aname args body maybeType

108+

109+ Valid.Destruct region pattern body ->

110+ case canonicalize env (Can.DRoot 0) pattern of

111+ Result.Result bag warnings (Result.Ok cpattern) ->

112+ do let toError name () () = Error.DuplicateBindingName name

113+ destructors <- Result.untracked (Dups.detect toError (Bag.toList bag))

114+ Result.Result (toKeyBag index bag) warnings $ Result.Ok $

115+ Destruct region index (Can.Match cpattern destructors) body

116+

117+ Result.Result bag warnings (Result.Err err) ->

118+ Result.Result (toKeyBag index bag) warnings (Result.Err err)

119+

120+

121+toKeyBag :: Int -> Bag -> KeyBag

122+toKeyBag index bag =

123+ let

124+ redoInfo (Dups.Info region () _) =

125+ Dups.Info region () (A.A region index)

126+

127+ replaceWithIndex ( name, infos ) =

128+ ( name, map redoInfo infos )

129+ in

130+ Bag.map replaceWithIndex bag

131+

132+

133+

134+-- CANONICALIZE

135+

136+

137+type Bag =

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

139+

140+

141+canonicalize :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern

142+canonicalize env destructor (A.A region pattern) =

143+ A.A region <$>

144+ case pattern of

145+ Src.PAnything ->

146+ Result.ok Can.PAnything

147+

148+ Src.PVar name ->

149+ Result.accumulate

150+ (Bag.one (Dups.info name region () (A.A region destructor)))

151+ (Can.PVar name)

152+

153+ Src.PRecord fields ->

154+ let

155+ fieldToInfo (A.A reg name) =

156+ Dups.info name reg () (A.A reg (Can.DField name destructor))

157+ in

158+ Result.accumulate

159+ (Bag.fromList fieldToInfo fields)

160+ (Can.PRecord (map A.drop fields))

161+

162+ Src.PUnit ->

163+ Result.ok Can.PUnit

164+

165+ Src.PTuple a b cs ->

166+ Can.PTuple

167+ <$> canonicalize env (Can.DIndex 0 destructor) a

168+ <*> canonicalize env (Can.DIndex 1 destructor) b

169+ <*> canonicalizeTuple region env destructor cs

170+

171+ Src.PCtor nameRegion maybePrefix name patterns ->

172+ let

173+ ctorArg ptrn index =

174+ canonicalize env (Can.DIndex index destructor) ptrn

175+ in

176+ Can.PCtor

177+ <$> Env.findPattern nameRegion env maybePrefix name (length patterns)

178+ <*> pure name

179+ <*> zipWithM ctorArg patterns [ 0 .. length patterns ]

180+

181+ Src.PList patterns ->

182+ Can.PList <$> canonicalizeList env destructor patterns

183+

184+ Src.PCons first rest ->

185+ Can.PCons

186+ <$> canonicalize env (Can.DIndex 0 destructor) first

187+ <*> canonicalize env (Can.DIndex 1 destructor) rest

188+

189+ Src.PAlias ptrn (A.A reg name) ->

190+ do cpattern <- canonicalize env destructor ptrn

191+ let info = Dups.info name reg () (A.A reg destructor)

192+ Result.accumulate (Bag.one info) (Can.PAlias cpattern name)

193+

194+ Src.PLiteral lit ->

195+ Result.ok (Can.PLiteral lit)

196+

197+

198+canonicalizeTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)

199+canonicalizeTuple tupleRegion env destructor extras =

200+ case extras of

201+ [] ->

202+ Result.ok Nothing

203+

204+ [three] ->

205+ Just <$> canonicalize env (Can.DIndex 2 destructor) three

206+

207+ _ : others ->

208+ let (A.A r1 _, A.A r2 _) = (head others, last others) in

209+ Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))

210+

211+

212+canonicalizeList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]

213+canonicalizeList env destructor list =

214+ case list of

215+ [] ->

216+ Result.ok []

217+

218+ pattern : otherPatterns ->

219+ (:)

220+ <$> canonicalize env (Can.DIndex 0 destructor) pattern

221+ <*> canonicalizeList env (Can.DIndex 1 destructor) otherPatterns

src/Canonicalize/Sort.hsdeleted−346

@@ -1,346 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Sort (definitions) where

3−

4−import qualified Data.Foldable as F

5−import qualified Data.Graph as Graph

6−import qualified Data.Map as Map

7−import qualified Data.Maybe as Maybe

8−import qualified Data.Set as Set

9−import Data.Text (Text)

10−

11−import qualified AST.Expression.Canonical as C

12−import qualified AST.Pattern as P

13−import qualified AST.Variable as V

14−import qualified Reporting.Annotation as A

15−import qualified Reporting.Error.Canonicalize as E

16−import qualified Reporting.Result as R

17−

18−

19−

20−-- SORT DEFINITIONS

21−

22−

23−definitions :: (Monoid i) => C.Expr -> R.Result i w E.Error C.Expr

24−definitions expression =

25− let

26− (R.Result _ warnings answer) =

27− reorder expression

28− in

29− R.Result mempty warnings answer

30−

31−

32−data LocalVars =

33− LocalVars

34− { _immediate :: Set.Set Text

35− , _delayed :: Set.Set Text

36− , _tags :: Set.Set Text

37− }

38−

39−

40−instance Monoid LocalVars where

41− mempty =

42− LocalVars Set.empty Set.empty Set.empty

43−

44− mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =

45− LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)

46−

47−

48−addTag :: Text -> a -> R.Result LocalVars w e a

49−addTag name value =

50− R.accumulate (LocalVars Set.empty Set.empty (Set.singleton name)) value

51−

52−

53−addImmediate :: V.Canonical -> a -> R.Result LocalVars w e a

54−addImmediate (V.Canonical home name) value =

55− case home of

56− V.Local ->

57− R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value

58−

59− V.TopLevel _ ->

60− R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value

61−

62− V.BuiltIn ->

63− return value

64−

65− V.Module _ ->

66− return value

67−

68−

69−capture :: P.Canonical -> R.Result LocalVars w e a -> R.Result LocalVars w e a

70−capture pattern result =

71− captureVars (P.boundVarSet pattern) result

72−

73−

74−captureVars :: Set.Set Text -> R.Result LocalVars w e a -> R.Result LocalVars w e a

75−captureVars bound (R.Result (LocalVars immediate delayed tags) warnings result) =

76− let

77− localVars =

78− LocalVars (Set.difference immediate bound) (Set.difference delayed bound) tags

79− in

80− R.Result localVars warnings result

81−

82−

83−delay :: R.Result LocalVars w e a -> R.Result LocalVars w e a

84−delay (R.Result (LocalVars immediate delayed tags) warnings result) =

85− R.Result (LocalVars Set.empty (Set.union immediate delayed) tags) warnings result

86−

87−

88−

89−-- REORDER EXPRESSIONS

90−

91−

92−reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr

93−reorder (A.A region expression) =

94− A.A region <$>

95− case expression of

96− C.Var var ->

97− addImmediate var expression

98−

99− C.Lambda pattern body ->

100− delay $

101− bindingReorder C.Lambda (pattern, body)

102−

103− C.Binop op leftExpr rightExpr ->

104− do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr

105− addImmediate op binop

106−

107− C.Case expr cases ->

108− C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases

109−

110− C.Ctor ctor@(V.Canonical _ name) exprs ->

111− addTag name =<< (C.Ctor ctor <$> traverse reorder exprs)

112−

113− -- Just pipe the reorder though

114− C.Literal _ ->

115− return expression

116−

117− C.List es ->

118− C.List <$> traverse reorder es

119−

120− C.App func arg ->

121− C.App <$> reorder func <*> reorder arg

122−

123− C.If branches finally ->

124− C.If

125− <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

126− <*> reorder finally

127−

128− C.Access record field ->

129− C.Access

130− <$> reorder record

131− <*> return field

132−

133− C.Update record fields ->

134− C.Update

135− <$> reorder record

136− <*> traverse (traverse reorder) fields

137−

138− C.Record fields ->

139− C.Record

140− <$> traverse (traverse reorder) fields

141−

142− C.Cmd _ _ ->

143− return expression

144−

145− C.Sub _ _ ->

146− return expression

147−

148− C.OutgoingPort _ _ ->

149− return expression

150−

151− C.IncomingPort _ _ ->

152− return expression

153−

154− C.Program _ _ ->

155− error "DANGER - Program AST nodes should not be in def sorting."

156−

157− C.SaveEnv _ _ ->

158− return expression

159−

160− C.GLShader _ _ _ ->

161− return expression

162−

163− -- Actually do some reordering

164− C.Let defs body ->

165− case reorderDefs defs of

166− R.Result () warnings (R.Err errors) ->

167− R.Result mempty warnings (R.Err errors)

168−

169− R.Result () warnings (R.Ok (boundVars, defGroups, defLocals)) ->

170− captureVars boundVars $

171− do _ <- R.Result mempty warnings (R.Ok ())

172− newBody <- reorder body

173− R.accumulate defLocals $ A.drop $

174− foldr (\defGroup expr -> A.A region (C.Let defGroup expr)) newBody defGroups

175−

176−

177−

178−-- BINDINGS

179−

180−

181−bindingReorder

182− :: (P.Canonical -> C.Expr -> a)

183− -> (P.Canonical, C.Expr)

184− -> R.Result LocalVars w E.Error a

185−bindingReorder func (pattern, expr) =

186− do answer <- func pattern <$> capture pattern (reorder expr)

187− addPatternTags pattern answer

188−

189−

190−

191−-- FREE CONSTRUCTORS

192−

193−

194−addPatternTags :: P.Canonical -> a -> R.Result LocalVars w e a

195−addPatternTags pattern value =

196− R.accumulate (LocalVars Set.empty Set.empty (getPatternTags pattern)) value

197−

198−

199−getPatternTags :: P.Canonical -> Set.Set Text

200−getPatternTags (A.A _ pattern) =

201− case pattern of

202− P.Var _ ->

203− Set.empty

204−

205− P.Alias _ subPattern ->

206− getPatternTags subPattern

207−

208− P.Record _ ->

209− Set.empty

210−

211− P.Anything ->

212− Set.empty

213−

214− P.Literal _ ->

215− Set.empty

216−

217− P.Ctor (V.Canonical home name) patterns ->

218− let

219− freeCtors =

220− Set.unions (map getPatternTags patterns)

221− in

222− case home of

223− V.Local ->

224− Set.insert name freeCtors

225−

226− V.TopLevel _ ->

227− Set.insert name freeCtors

228−

229− V.BuiltIn ->

230− freeCtors

231−

232− V.Module _ ->

233− freeCtors

234−

235−

236−

237−-- REORDER DEFINITIONS

238−

239−

240−reorderDefs

241− :: [C.Def]

242− -> R.Result () w E.Error (Set.Set Text, [[C.Def]], LocalVars)

243−reorderDefs defs =

244− do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs

245− let boundVarDict = toBoundVarDict rawNodes

246− _ <- detectLoops boundVarDict rawNodes

247− return $ groupDefs boundVarDict rawNodes

248−

249−

250−toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)

251−toRawNode index (C.Def region pattern body maybeType) =

252− let

253− (R.Result localVars warnings answer) =

254− addPatternTags pattern =<< reorder body

255−

256− toRawNodeHelp newBody =

257− ( C.Def region pattern newBody maybeType, index, localVars )

258− in

259− toRawNodeHelp <$> R.Result () warnings answer

260−

261−

262−toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map Text Int

263−toBoundVarDict defAndDeps =

264− Map.fromList (concatMap toBoundVarDictHelp defAndDeps)

265−

266−

267−toBoundVarDictHelp :: (C.Def, Int, a) -> [(Text, Int)]

268−toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =

269− map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)

270−

271−

272−

273−-- BUILD GRAPHS

274−

275−

276−toNode

277− :: (deps -> [Text])

278− -> Map.Map Text Int

279− -> (C.Def, Int, deps)

280− -> (C.Def, Int, [Int])

281−toNode toVars boundVarDict (def, index, deps) =

282− let

283− localDeps =

284− Maybe.mapMaybe (\var -> Map.lookup var boundVarDict) (toVars deps)

285− in

286− ( def, index, localDeps )

287−

288−

289−immediateOnly :: LocalVars -> [Text]

290−immediateOnly (LocalVars immediate _ _) =

291− Set.toList immediate

292−

293−

294−allVars :: LocalVars -> [Text]

295−allVars (LocalVars immediate delayed tags) =

296− Set.toList immediate ++ Set.toList delayed ++ Set.toList tags

297−

298−

299−

300−-- DETECT LOOPS

301−

302−

303−detectLoops

304− :: Map.Map Text Int

305− -> [(C.Def, Int, LocalVars)]

306− -> R.Result () w E.Error ()

307−detectLoops boundVarDict rawNodes =

308− F.traverse_ detectLoopsHelp $

309− Graph.stronglyConnComp $

310− map (toNode immediateOnly boundVarDict) rawNodes

311−

312−

313−detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()

314−detectLoopsHelp scc =

315− case scc of

316− Graph.AcyclicSCC _ ->

317− R.ok ()

318−

319− Graph.CyclicSCC defs ->

320− case defs of

321− [] ->

322− R.ok ()

323−

324− def@(C.Def region (A.A nameRegion _) _ _) : rest ->

325− R.throw region $ E.BadRecursion nameRegion def rest

326−

327−

328−

329−-- GROUP DEFINITIONS

330−

331−

332−groupDefs

333− :: Map.Map Text Int

334− -> [(C.Def, Int, LocalVars)]

335− -> ( Set.Set Text, [[C.Def]], LocalVars )

336−groupDefs boundVarDict rawNodes =

337− let

338− allLocalVars =

339− mconcat (map (\(_, _, localVars) -> localVars) rawNodes)

340−

341− defGroups =

342− map Graph.flattenSCC $

343− Graph.stronglyConnComp $

344− map (toNode allVars boundVarDict) rawNodes

345− in

346− ( Map.keysSet boundVarDict, defGroups, allLocalVars )

src/Canonicalize/Type.hs+25−10

@@ -12,22 +12,37 @@ import qualified AST.Type as Type

12import qualified Canonicalize.Environment.Dups as Dups

13import qualified Canonicalize.Environment.Internals as Env

14import qualified Reporting.Annotation as A

15+import qualified Reporting.Error.Canonicalize as Error

15import qualified Reporting.Result as Result

16import qualified Reporting.Result as Result

17+import qualified Reporting.Warning as Warning

18+

19+

20+

21+-- RESULT

22+

23+

24+type Result i a =

25+ Result.Result i Warning.Warning Error.Error a

19-- CANONICALIZE TYPES

29-- CANONICALIZE TYPES

22−canonicalize :: Env.Env -> Type.Raw -> Env.Result Type.Canonical

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

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

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

35+

36+

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

23−canonicalize env (A.A _ tipe) =

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

24 case tipe of

39 case tipe of

25 Type.RVar x ->

40 Type.RVar x ->

26 Result.ok (Type.Var x)

41 Result.ok (Type.Var x)

28 Type.RType region maybePrefix name args ->

43 Type.RType region maybePrefix name args ->

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

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

30− cargs <- traverse (canonicalize env) args

45+ cargs <- traverse (canonicalizeHelp env) args

31 return $

46 return $

32 case info of

47 case info of

33 Env.Alias home argNames aliasedType ->

48 Env.Alias home argNames aliasedType ->

@@ -38,20 +53,20 @@ canonicalize env (A.A _ tipe) =

39 Type.RLambda a b ->

54 Type.RLambda a b ->

40 Type.Lambda

55 Type.Lambda

41− <$> canonicalize env a

56+ <$> canonicalizeHelp env a

42− <*> canonicalize env b

57+ <*> canonicalizeHelp env b

44 Type.RRecord fields ext ->

59 Type.RRecord fields ext ->

45 do fieldDict <- Dups.checkFields fields

60 do fieldDict <- Dups.checkFields fields

46 Type.Record

61 Type.Record

47− <$> Map.traverseWithKey (\_ t -> canonicalize env t) fieldDict

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

48− <*> traverse (canonicalize env) ext

63+ <*> traverse (canonicalizeHelp env) ext

50 Type.RUnit ->

65 Type.RUnit ->

51 Result.ok Type.Unit

66 Result.ok Type.Unit

53 Type.RTuple a b cs ->

68 Type.RTuple a b cs ->

54 Type.Tuple

69 Type.Tuple

55− <$> canonicalize env a

70+ <$> canonicalizeHelp env a

56− <*> canonicalize env b

71+ <*> canonicalizeHelp env b

57− <*> traverse (canonicalize env) cs

72+ <*> traverse (canonicalizeHelp env) cs