63fb3d0 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Ensure that free type variables are computed only once

63fb3d0Evan Czaplicki9 years ago

src/AST/Canonical.hs+44−35

compare with master

unifiedsplit

@@ -2,15 +2,16 @@

2{-# LANGUAGE OverloadedStrings #-}

3module AST.Canonical

4 ( Expr, Expr_(..)

5+ , CaseBranch(..)

5 , Def(..)

6 , Def(..)

6− -- patterns

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

8− , Match(..)

8+ -- patterns

9 , Pattern, Pattern_(..)

10 , PatternCtorArg(..)

11 , Destructors

12 , Destructor(..)

13 -- types

14+ , Annotation(..)

14 , Type(..)

15 , Type(..)

15 , AliasType(..)

16 , AliasType(..)

16 -- decls

17 -- decls

@@ -41,7 +42,6 @@ import qualified AST.Module.Name as ModuleName

41import qualified AST.Utils.Shader as Shader

42import qualified AST.Utils.Shader as Shader

42import qualified Data.Index as Index

43import qualified Data.Index as Index

43import qualified Elm.Name as N

44import qualified Elm.Name as N

44−import Elm.Name (Name)

45import qualified Reporting.Annotation as A

46import qualified Reporting.Region as R

@@ -55,32 +55,41 @@ type Expr =

57data Expr_

58− = VarLocal Name

58+ = VarLocal N.Name

59− | VarTopLevel ModuleName.Canonical Name

59+ | VarTopLevel ModuleName.Canonical N.Name

60− | VarKernel Name Name

60+ | VarKernel N.Name N.Name

61− | VarForeign ModuleName.Canonical Name

61+ | VarForeign ModuleName.Canonical N.Name Annotation

62− | VarOperator Name ModuleName.Canonical Name

62+ | VarOperator N.Name ModuleName.Canonical N.Name Annotation

63 | Chr Text

64 | Str Text

65 | Int Int

66 | Float Double

67 | List [Expr]

68 | Negate Expr

69− | Binop Name ModuleName.Canonical Name Expr Expr

69+ | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr

70 | Lambda Args Expr

71 | Call Expr [Expr]

72 | If [(Expr, Expr)] Expr

73 | Let Def Expr

74 | LetRec [Def] Expr

75− | LetDestruct Match Expr Expr

75+ | LetDestruct Pattern Destructors Expr Expr

76− | Case Expr [(Match, Expr)]

76+ | Case Expr [CaseBranch]

77− | Accessor Name

77+ | Accessor N.Name

78− | Access Expr Name

78+ | Access Expr N.Name

79− | Update Expr (Map.Map Name Expr)

79+ | Update Expr (Map.Map N.Name Expr)

80− | Record (Map.Map Name Expr)

80+ | Record (Map.Map N.Name Expr)

81 | Unit

82 | Tuple Expr Expr (Maybe Expr)

83− | Shader Name Name Shader.Shader

83+ | Shader N.Name N.Name Shader.Shader

84+

85+

86+data CaseBranch =

87+ CaseBranch

88+ { _branch_index :: Index.ZeroBased

89+ , _branch_pattern :: Pattern

90+ , _branch_destructors :: Destructors

91+ , _branch_expr :: Expr

92+ }

@@ -88,22 +97,19 @@ data Expr_

90data Def =

99data Def =

91− Def

92− { _def_name :: A.Located N.Name

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

93− , _def_args :: Args

94− , _def_body :: Expr

95− , _def_type :: Maybe Type

96− }

101

102

103+data Args =

104+ Args [Arg] Destructors

105

100−-- PATTERNS

106+

107+data Arg =

108+ Arg Index.ZeroBased Pattern

101

109

102

110

103−data Args = Args [Arg] Destructors

104−data Arg = Arg Index.ZeroBased Pattern

105

111

106−data Match = Match Pattern Destructors

112+-- PATTERNS

107

113

108

114

109type Pattern = A.Located Pattern_

115type Pattern = A.Located Pattern_

@@ -149,14 +155,17 @@ data Destructor

149-- TYPES

155-- TYPES

150

156

151

157

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

159+

160+

152data Type

161data Type

153 = TLambda Type Type

162 = TLambda Type Type

154− | TVar Name

163+ | TVar N.Name

155− | TType ModuleName.Canonical Name [Type]

164+ | TType ModuleName.Canonical N.Name [Type]

156− | TRecord (Map.Map Name Type) (Maybe Type)

165+ | TRecord (Map.Map N.Name Type) (Maybe Type)

157 | TUnit

166 | TUnit

158 | TTuple Type Type (Maybe Type)

167 | TTuple Type Type (Maybe Type)

159− | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType

168+ | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType

160

169

161

170

162data AliasType

171data AliasType

@@ -175,8 +184,8 @@ data Decls

175

184

176

185

177data Decl

186data Decl

178− = Value N.Name Expr (Maybe Type)

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

179− | Function N.Name Args Expr (Maybe Type)

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

180

189

181

190

182

191

@@ -265,9 +274,9 @@ instance Binary Union where

265 put (Union a b) = put a >> put b

274 put (Union a b) = put a >> put b

266

275

267

276

268−instance Binary Binop where

277+instance Binary Annotation where

269− get = liftM3 Binop_ get get get

278+ get = liftM2 Forall get get

270− put (Binop_ a b c) = put a >> put b >> put c

279+ put (Forall a b) = put a >> put b

271

280

272

281

273instance Binary Type where

282instance Binary Type where

src/Canonicalize/Environment/Foreign.hs+21−15

@@ -39,7 +39,7 @@ type Result a =

40data Env =

41 Env

42− { _vars :: Map.Map N.Name (Env.Homes ModuleName.Canonical)

42+ { _vars :: Map.Map N.Name (Env.Homes Env.ForeignVarHome)

43 , _types :: Map.Map N.Name (Env.Homes Env.Type)

44 , _patterns :: Map.Map N.Name (Env.Homes Env.Pattern)

45 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)

@@ -96,7 +96,7 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi

96 case exposing of

97 Open ->

98 Env

99− (Map.map (toOpenHomes home prefix const) types)

99+ (Map.map (toOpenHomes home prefix toVarInfo) types)

100 (Map.unionWith mergeHomes

101 (Map.map (toOpenHomes home prefix toUnionInfo) unions)

102 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)

@@ -106,7 +106,7 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi

106

107 Explicit explicits ->

108 Env

109− (Map.mapWithKey (toExplicitHomes home prefix explicits const toValueBag) types)

109+ (Map.mapWithKey (toExplicitHomes home prefix explicits toVarInfo toVarBag) types)

110 (Map.unionWith mergeHomes

111 (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)

112 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)

@@ -118,9 +118,9 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi

118toOpenHomes

119 :: ModuleName.Canonical

120 -> N.Name

121− -> (ModuleName.Canonical -> a -> b)

121+ -> (ModuleName.Canonical -> value -> info)

122− -> a

122+ -> value

123− -> Env.Homes b

123+ -> Env.Homes info

124toOpenHomes home prefix toInfo value =

125 let info = toInfo home value in

126 Env.Homes

@@ -132,11 +132,11 @@ toExplicitHomes

132 :: ModuleName.Canonical

133 -> N.Name

134 -> Map.Map N.Name Exposed

135− -> (ModuleName.Canonical -> a -> b)

135+ -> (ModuleName.Canonical -> value -> info)

136− -> (b -> Maybe Exposed -> Bag.Bag b)

136+ -> (info -> Maybe Exposed -> Bag.Bag info)

137 -> N.Name

138− -> a

138+ -> value

139− -> Env.Homes b

139+ -> Env.Homes info

140toExplicitHomes home prefix explicits toInfo toBag name value =

141 let info = toInfo home value in

142 Env.Homes

@@ -144,15 +144,21 @@ toExplicitHomes home prefix explicits toInfo toBag name value =

144 (Map.singleton prefix (OneOrMore.one info))

145

146

147−toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop

147+toBinopHomes :: ModuleName.Canonical -> N.Name -> I.Op -> OneOrMore.OneOrMore Env.Binop

148−toBinopHomes home op (Can.Binop_ associativity precedence name) =

148+toBinopHomes home op (I.Op name annotation associativity precedence) =

149− OneOrMore.one (Env.Binop op home name associativity precedence)

149+ OneOrMore.one (Env.Binop op home name annotation associativity precedence)

150

151

152

153-- TO INFO

154

155

156+{-# INLINE toVarInfo #-}

157+toVarInfo :: ModuleName.Canonical -> Can.Annotation -> Env.ForeignVarHome

158+toVarInfo =

159+ Env.ForeignVarHome

160+

161+

156toUnionInfo :: ModuleName.Canonical -> Can.Union -> Env.Type

162toUnionInfo :: ModuleName.Canonical -> Can.Union -> Env.Type

157toUnionInfo home (Can.Union args _) =

163toUnionInfo home (Can.Union args _) =

158 Env.Union (length args) home

164 Env.Union (length args) home

@@ -181,8 +187,8 @@ toPatterns home (tipe, Can.Union vars ctors) =

181-- TO BAG

187-- TO BAG

182

188

183

189

184−toValueBag :: a -> Maybe Exposed -> Bag.Bag a

190+toVarBag :: a -> Maybe Exposed -> Bag.Bag a

185−toValueBag info maybeExposed =

191+toVarBag info maybeExposed =

186 case maybeExposed of

192 case maybeExposed of

187 Nothing ->

193 Nothing ->

188 Bag.empty

194 Bag.empty

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

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

5 , Env(..)

6 , VarHomes(..)

7 , UnqualifiedVarHome(..)

8+ , ForeignVarHome(..)

8 , Type(..)

9 , Type(..)

9 , Pattern(..)

10 , Pattern(..)

10 , Homes(..)

11 , Homes(..)

@@ -64,17 +65,29 @@ data Homes a =

64 }

65 }

68+

69+-- VARIABLES

70+

71+

67data VarHomes =

72data VarHomes =

68 VarHomes

73 VarHomes

69 { _var_unqualified :: UnqualifiedVarHome

74 { _var_unqualified :: UnqualifiedVarHome

70− , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ModuleName.Canonical)

75+ , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ForeignVarHome)

71 }

76 }

74data UnqualifiedVarHome

79data UnqualifiedVarHome

75 = Local

80 = Local

76 | TopLevel

81 | TopLevel

82+ | Foreign (Bag.Bag ForeignVarHome)

83+

84+

85+data ForeignVarHome =

77− | Foreign (Bag.Bag ModuleName.Canonical)

86+ ForeignVarHome ModuleName.Canonical Can.Annotation

87+

88+

89+

90+-- TYPES

80data Type

93data Type

@@ -82,6 +95,10 @@ data Type

82 | Union Int ModuleName.Canonical

95 | Union Int ModuleName.Canonical

98+

99+-- PATTERNs

100+

101+

85data Pattern =

102data Pattern =

86 Pattern

103 Pattern

87 { _p_home :: ModuleName.Canonical

104 { _p_home :: ModuleName.Canonical

@@ -91,11 +108,16 @@ data Pattern =

91 }

108 }

109

110

111+

112+-- BINOPS

113+

114+

94data Binop =

115data Binop =

95 Binop

116 Binop

96− { _op_name :: N.Name

117+ { _op :: N.Name

97 , _op_home :: ModuleName.Canonical

118 , _op_home :: ModuleName.Canonical

98− , _op_func :: N.Name

119+ , _op_name :: N.Name

120+ , _op_annotation :: Can.Annotation

99 , _op_associativity :: Binop.Associativity

121 , _op_associativity :: Binop.Associativity

100 , _op_precedence :: Binop.Precedence

122 , _op_precedence :: Binop.Precedence

101 }

123 }

@@ -141,7 +163,7 @@ addLocalBoth name (A.A region _) (VarHomes unqualified qualified) =

141

163

142

164

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

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

144−findVar region (Env home vars _ _ _) maybePrefix name =

166+findVar region (Env localHome vars _ _ _) maybePrefix name =

145 case Map.lookup name vars of

167 case Map.lookup name vars of

146 Nothing ->

168 Nothing ->

147 Result.throw region (error "TODO no name")

169 Result.throw region (error "TODO no name")

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

154 Result.accumulate (Set.singleton name) (Can.VarLocal name)

176 Result.accumulate (Set.singleton name) (Can.VarLocal name)

155

177

156 TopLevel ->

178 TopLevel ->

157− Result.accumulate (Set.singleton name) (Can.VarTopLevel home name)

179+ Result.accumulate (Set.singleton name) (Can.VarTopLevel localHome name)

158

180

159 Foreign bag ->

181 Foreign bag ->

160 case bag of

182 case bag of

161− Bag.One foreignHome ->

183+ Bag.One (ForeignVarHome home annotation) ->

162− Result.ok (Can.VarForeign foreignHome name)

184+ Result.ok (Can.VarForeign home name annotation)

163

185

164 Bag.Empty ->

186 Bag.Empty ->

165 Result.throw region (error "TODO no unqualified")

187 Result.throw region (error "TODO no unqualified")

@@ -172,8 +194,8 @@ findVar region (Env home vars _ _ _) maybePrefix name =

172 Nothing ->

194 Nothing ->

173 Result.throw region (error "TODO no qualified")

195 Result.throw region (error "TODO no qualified")

174

196

175− Just (OneOrMore.One foreignHome) ->

197+ Just (OneOrMore.One (ForeignVarHome home annotation)) ->

176− Result.ok (Can.VarForeign foreignHome name)

198+ Result.ok (Can.VarForeign home name annotation)

177

199

178 Just _ ->

200 Just _ ->

179 Result.throw region (error "TODO ambiguous qualified")

201 Result.throw region (error "TODO ambiguous qualified")

src/Canonicalize/Expression.hs+23−22

@@ -19,6 +19,7 @@ import qualified Canonicalize.Environment.Dups as Dups

19import qualified Canonicalize.Pattern as Pattern

20import qualified Canonicalize.Type as Type

21import qualified Data.Bag as Bag

22+import qualified Data.Index as Index

22import qualified Elm.Name as N

23import qualified Elm.Name as N

23import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

24import qualified Reporting.Error.Canonicalize as Error

25import qualified Reporting.Error.Canonicalize as Error

@@ -66,8 +67,8 @@ canonicalize env (A.A region expression) =

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

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

68 Valid.Op op ->

69 Valid.Op op ->

69− do (Env.Binop _ home name _ _) <- Env.findBinop region env op

70+ do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op

70− return (Can.VarOperator op home name)

71+ return (Can.VarOperator op home name annotation)

72 Valid.Negate expr ->

73 Valid.Negate expr ->

73 Can.Negate <$> canonicalize env expr

74 Can.Negate <$> canonicalize env expr

@@ -95,10 +96,10 @@ canonicalize env (A.A region expression) =

95 Valid.Let defs expr ->

96 Valid.Let defs expr ->

96 A.drop <$> canonicalizeLet region env defs expr

97 A.drop <$> canonicalizeLet region env defs expr

98− Valid.Case expr cases ->

99+ Valid.Case expr branches ->

99 Can.Case

100 Can.Case

100 <$> canonicalize env expr

101 <$> canonicalize env expr

101− <*> traverse (canonicalizeCaseBranch env) cases

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

102

103

103 Valid.Accessor field ->

104 Valid.Accessor field ->

104 Result.ok $ Can.Accessor field

105 Result.ok $ Can.Accessor field

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

164-- CANONICALIZE CASE BRANCH

165-- CANONICALIZE CASE BRANCH

165

166

167

167−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals (Can.Match, Can.Expr)

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

168−canonicalizeCaseBranch env (pattern, expr) =

169+canonicalizeCaseBranch env index (pattern, expr) =

169 addLocals $

170 addLocals $

170− do match@(Can.Match _ destructors) <- Pattern.canonicalizeMatch env pattern

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

171 newEnv <- Env.addLocals destructors env

172 newEnv <- Env.addLocals destructors env

172 removeLocals Warning.Pattern destructors $

173 removeLocals Warning.Pattern destructors $

173− (,) match <$> canonicalize newEnv expr

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

174

175

176

177

@@ -211,17 +212,17 @@ runBinopStepper overallRegion step =

211 runBinopStepper overallRegion $

212 runBinopStepper overallRegion $

212 toBinopStep (toBinop op expr) op rest final

213 toBinopStep (toBinop op expr) op rest final

213

214

214− Error (Env.Binop op1 _ _ _ _) (Env.Binop op2 _ _ _ _) ->

215+ Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->

215 Result.throw overallRegion (Error.Binop op1 op2)

216 Result.throw overallRegion (Error.Binop op1 op2)

216

217

218

218toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step

219toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step

219−toBinopStep makeBinop rootOp@(Env.Binop _ _ _ rootAssociativity rootPrecedence) middle final =

220+toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final =

220 case middle of

221 case middle of

221 [] ->

222 [] ->

222 Done (makeBinop final)

223 Done (makeBinop final)

223

224

224− ( expr, op@(Env.Binop _ _ _ associativity precedence) ) : rest ->

225+ ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest ->

225 if precedence < rootPrecedence then

226 if precedence < rootPrecedence then

226

227

227 More ((makeBinop expr, op) : rest) final

228 More ((makeBinop expr, op) : rest) final

@@ -252,8 +253,8 @@ toBinopStep makeBinop rootOp@(Env.Binop _ _ _ rootAssociativity rootPrecedence)

252

253

254

254toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr

255toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr

255−toBinop (Env.Binop op home name _ _) left right =

256+toBinop (Env.Binop op home name annotation _ _) left right =

256− A.merge left right (Can.Binop op home name left right)

257+ A.merge left right (Can.Binop op home name annotation left right)

257

258

259

260

@@ -316,7 +317,7 @@ toUnusedWarning unused (name, A.A region _) =

316

317

317data Binding

318data Binding

318 = Define R.Region Can.Def

319 = Define R.Region Can.Def

319− | Destruct R.Region Can.Match Can.Expr

320+ | Destruct R.Region Can.Pattern Can.Destructors Can.Expr

320

321

322

322data Node = Node Binding FreeLocals

323data Node = Node Binding FreeLocals

@@ -327,15 +328,15 @@ bindingToNode defKeys env binding =

327 case binding of

328 case binding of

328 Pattern.Define region index name args body maybeType ->

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

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

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

330− ctype <- traverse (Type.canonicalize env) maybeType

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

331 newEnv <- Env.addLocals destructors env

332 newEnv <- Env.addLocals destructors env

332 toNode defKeys destructors index $

333 toNode defKeys destructors index $

333 do cbody <- canonicalize newEnv body

334 do cbody <- canonicalize newEnv body

334− return (Define region (Can.Def name cargs cbody ctype))

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

335

336

336− Pattern.Destruct region index match body ->

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

337 toNode defKeys Map.empty index $

338 toNode defKeys Map.empty index $

338− Destruct region match <$> canonicalize env body

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

339

340

341

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

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

@@ -376,8 +377,8 @@ detectCycles region sccs body =

376 Result.accumulate freeLocals (Can.Let def)

377 Result.accumulate freeLocals (Can.Let def)

377 <*> detectCycles region subSccs body

378 <*> detectCycles region subSccs body

378

379

379− Destruct _ match expr ->

380+ Destruct _ pattern destructors expr ->

380− Result.accumulate freeLocals (Can.LetDestruct match expr)

381+ Result.accumulate freeLocals (Can.LetDestruct pattern destructors expr)

381 <*> detectCycles region subSccs body

382 <*> detectCycles region subSccs body

382

383

383 Graph.CyclicSCC nodes ->

384 Graph.CyclicSCC nodes ->

@@ -402,7 +403,7 @@ requireDefine (Node binding freeLocals) =

402 _ ->

403 _ ->

403 Just (def, freeLocals)

404 Just (def, freeLocals)

404

405

405− Destruct _ _ _ ->

406+ Destruct _ _ _ _ ->

406 Nothing

407 Nothing

407

408

409

@@ -417,5 +418,5 @@ toCycleNodes (Node binding _) =

417 _ ->

418 _ ->

418 Error.CycleFunc name

419 Error.CycleFunc name

419

420

420− Destruct _ (Can.Match pattern _) _ ->

421+ Destruct _ pattern _ _ ->

421 Error.CyclePattern pattern

422 Error.CyclePattern pattern

src/Canonicalize/Module.hs+14−6

@@ -167,23 +167,31 @@ toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])

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

168 case args of

169 [] ->

170− do ctipe <- traverse (Type.canonicalize env) tipe

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

173− return (Value region name cbody ctipe, key, Set.toList freeLocals)

176+ , Set.toList freeLocals

177+ )

174

178

175 _ ->

179 _ ->

176− do ctipe <- traverse (Type.canonicalize env) tipe

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

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

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

178 newEnv <- Env.addLocals destructors env

182 newEnv <- Env.addLocals destructors env

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

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

180 Expr.canonicalize newEnv body

184 Expr.canonicalize newEnv body

185+ return

186+ ( Function key cargs cbody annotation

187+ , key

181− return (Function key cargs cbody ctipe, key, Set.toList freeLocals)

188+ , Set.toList freeLocals

189+ )

182

190

183

191

184data Decl

192data Decl

185− = Value R.Region (A.Located N.Name) Can.Expr (Maybe Can.Type)

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

186− | Function N.Name Can.Args Can.Expr (Maybe Can.Type)

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

187

195

188

196

189toCanDecl :: Decl -> Can.Decl

197toCanDecl :: Decl -> Can.Decl

src/Canonicalize/Pattern.hs+39−40

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

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize.Pattern

3− ( canonicalizeArgs

3+ ( canonicalize

4− , canonicalizeMatch

4+ , canonicalizeArgs

5 , canonicalizeBindings

6 , Binding(..)

7 )

@@ -35,51 +35,50 @@ type Result i =

38−-- CANONICALIZE ARGS

38+-- CANONICALIZE

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

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

42−canonicalizeArgs env patterns =

42+canonicalize env index pattern =

43− case Index.indexedTraverse (canonicalizeArg env) patterns of

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

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

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

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

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

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

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

48− Can.Args args destructors

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

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

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

50 Result.Result () warnings (Result.Err err)

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

55−canonicalizeArg env index pattern =

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

57−

58−

60−-- CANONICALIZE MATCH

54+-- CANONICALIZE ARGS

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

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

64−canonicalizeMatch env pattern =

58+canonicalizeArgs env patterns =

65− case canonicalize env (Can.DRoot Index.first) pattern of

59+ case Index.indexedTraverse (canonicalizeArg env) patterns of

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

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

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

61 do let toError name () () = Error.DuplicateArg name

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

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

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

63 Result.Result () warnings $ Result.Ok $

70− Can.Match cpattern destructors

64+ Can.Args args destructors

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

66 Result.Result _ warnings (Result.Err err) ->

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

67 Result.Result () warnings (Result.Err err)

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

71+canonicalizeArg env index pattern =

72+ Can.Arg index <$> process env (Can.DRoot index) pattern

73+

74+

77-- CANONICALIZE BINDINGS

76-- CANONICALIZE BINDINGS

80data Binding

79data Binding

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

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

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

81+ | Destruct R.Region Int Can.Pattern Can.Destructors Valid.Expr

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

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

@@ -107,12 +106,12 @@ canonicalizeBinding env def index =

107 Define region index aname args body maybeType

106 Define region index aname args body maybeType

108

107

109 Valid.Destruct region pattern body ->

108 Valid.Destruct region pattern body ->

110− case canonicalize env (Can.DRoot Index.first) pattern of

109+ case process env (Can.DRoot Index.first) pattern of

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

110 Result.Result bag warnings (Result.Ok cpattern) ->

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

111 do let toError name () () = Error.DuplicateBindingName name

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

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

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

113 Result.Result (toKeyBag index bag) warnings $ Result.Ok $

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

114+ Destruct region index cpattern destructors body

116

115

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

116 Result.Result bag warnings (Result.Err err) ->

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

117 Result.Result (toKeyBag index bag) warnings (Result.Err err)

@@ -138,8 +137,8 @@ type Bag =

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

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

139

138

140

139

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

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

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

141+process env destructor (A.A region pattern) =

143 A.A region <$>

142 A.A region <$>

144 case pattern of

143 case pattern of

145 Src.PAnything ->

144 Src.PAnything ->

@@ -164,15 +163,15 @@ canonicalize env destructor (A.A region pattern) =

164

163

165 Src.PTuple a b cs ->

164 Src.PTuple a b cs ->

166 Can.PTuple

165 Can.PTuple

167− <$> canonicalize env (Can.DIndex Index.first destructor) a

166+ <$> process env (Can.DIndex Index.first destructor) a

168− <*> canonicalize env (Can.DIndex Index.second destructor) b

167+ <*> process env (Can.DIndex Index.second destructor) b

169− <*> canonicalizeTuple region env destructor cs

168+ <*> processTuple region env destructor cs

170

169

171 Src.PCtor nameRegion maybePrefix name patterns ->

170 Src.PCtor nameRegion maybePrefix name patterns ->

172 let

171 let

173 toCanonicalArg index ptrn tipe =

172 toCanonicalArg index ptrn tipe =

174 Can.PatternCtorArg index tipe

173 Can.PatternCtorArg index tipe

175− <$> canonicalize env (Can.DIndex index destructor) ptrn

174+ <$> process env (Can.DIndex index destructor) ptrn

176 in

175 in

177 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name

176 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name

178 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

177 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

@@ -184,15 +183,15 @@ canonicalize env destructor (A.A region pattern) =

184 Result.throw region (error "TODO" actualLength expectedLength)

183 Result.throw region (error "TODO" actualLength expectedLength)

185

184

186 Src.PList patterns ->

185 Src.PList patterns ->

187− Can.PList <$> canonicalizeList env destructor patterns

186+ Can.PList <$> processList env destructor patterns

188

187

189 Src.PCons first rest ->

188 Src.PCons first rest ->

190 Can.PCons

189 Can.PCons

191− <$> canonicalize env (Can.DIndex Index.first destructor) first

190+ <$> process env (Can.DIndex Index.first destructor) first

192− <*> canonicalize env (Can.DIndex Index.second destructor) rest

191+ <*> process env (Can.DIndex Index.second destructor) rest

193

192

194 Src.PAlias ptrn (A.A reg name) ->

193 Src.PAlias ptrn (A.A reg name) ->

195− do cpattern <- canonicalize env destructor ptrn

194+ do cpattern <- process env destructor ptrn

196 let info = Dups.info name reg () (A.A reg destructor)

195 let info = Dups.info name reg () (A.A reg destructor)

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

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

198

197

@@ -206,27 +205,27 @@ canonicalize env destructor (A.A region pattern) =

206 Result.ok (Can.PInt int)

205 Result.ok (Can.PInt int)

207

206

208

207

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

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

210−canonicalizeTuple tupleRegion env destructor extras =

209+processTuple tupleRegion env destructor extras =

211 case extras of

210 case extras of

212 [] ->

211 [] ->

213 Result.ok Nothing

212 Result.ok Nothing

214

213

215 [three] ->

214 [three] ->

216− Just <$> canonicalize env (Can.DIndex Index.third destructor) three

215+ Just <$> process env (Can.DIndex Index.third destructor) three

217

216

218 _ : others ->

217 _ : others ->

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

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

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

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

221

220

222

221

223−canonicalizeList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]

222+processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]

224−canonicalizeList env destructor list =

223+processList env destructor list =

225 case list of

224 case list of

226 [] ->

225 [] ->

227 Result.ok []

226 Result.ok []

228

227

229 pattern : otherPatterns ->

228 pattern : otherPatterns ->

230 (:)

229 (:)

231− <$> canonicalize env (Can.DIndex Index.first destructor) pattern

230+ <$> process env (Can.DIndex Index.first destructor) pattern

232− <*> canonicalizeList env (Can.DIndex Index.second destructor) otherPatterns

231+ <*> processList env (Can.DIndex Index.second destructor) otherPatterns

src/Canonicalize/Type.hs+51−1

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

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Canonicalize.Type

4+ ( toAnnotation

4− ( canonicalize

5+ , canonicalize

6+ , addFreeVars

5 )

7 )

6 where

8 where

@@ -29,6 +31,16 @@ type Result i a =

34+-- TO ANNOTATION

35+

36+

37+toAnnotation :: Env.Env -> Src.Type -> Result () Can.Annotation

38+toAnnotation env srcType =

39+ do tipe <- canonicalize env srcType

40+ return $ Can.Forall (addFreeVars tipe Map.empty) tipe

41+

42+

43+

32-- CANONICALIZE TYPES

44-- CANONICALIZE TYPES

@@ -101,3 +113,41 @@ checkArgs argsType expected region name args answer =

101 (A.A start _, A.A end _) = (head extras, last extras)

113 (A.A start _, A.A end _) = (head extras, last extras)

102 in

114 in

103 Error.TooMany argsType name expected actual (R.merge start end)

115 Error.TooMany argsType name expected actual (R.merge start end)

116+

117+

118+

119+-- ADD FREE VARS

120+

121+

122+addFreeVars :: Can.Type -> Map.Map N.Name () -> Map.Map N.Name ()

123+addFreeVars tipe freeVars =

124+ case tipe of

125+ Can.TLambda arg result ->

126+ addFreeVars arg (addFreeVars result freeVars)

127+

128+ Can.TVar var ->

129+ Map.insert var () freeVars

130+

131+ Can.TType _ _ args ->

132+ foldr addFreeVars freeVars args

133+

134+ Can.TRecord fields Nothing ->

135+ Map.foldr addFreeVars freeVars fields

136+

137+ Can.TRecord fields (Just ext) ->

138+ addFreeVars ext (Map.foldr addFreeVars freeVars fields)

139+

140+ Can.TUnit ->

141+ freeVars

142+

143+ Can.TTuple a b maybeC ->

144+ addFreeVars a $ addFreeVars b $

145+ case maybeC of

146+ Nothing ->

147+ freeVars

148+

149+ Just c ->

150+ addFreeVars c freeVars

151+

152+ Can.TAlias _ _ args _ ->

153+ foldr addFreeVars freeVars (map snd args)