63fb3d0 · elk · git.iko.soy

git.iko.soy/elk

Ensure that free type variables are computed only once

This introduces the AST.Canonical.Annotation type that holds on to all the free type variables in a type. This is then attached to an VarForeign, VarOperator, or Binop nodes such that we can go from AST.Canonical.Type directly to a unification variable during type inference. Computing and caching the free type variables during canonicalization means that this work does not need to happen on each use of (|>) or List.map or whatever else. It may be worth experimenting to see if this is better overall. Perhaps the memory overhead of having the type variables for stuff that isn’t used is not worth it.

commit63fb3d007a2b755785ef61829afa4bfacc4627fd authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 10 Nov 2017, 16:35 (9 years ago) parentd9985bc

7 files changed+224−129

compare with master

unifiedsplit

src/AST/Canonical.hs+44−35 src/Canonicalize/Environment/Foreign.hs+21−15 src/Canonicalize/Environment/Internals.hs+32−10 src/Canonicalize/Expression.hs+23−22 src/Canonicalize/Module.hs+14−6 src/Canonicalize/Pattern.hs+39−40 src/Canonicalize/Type.hs+51−1

src/AST/Canonical.hs+44−35

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

22{-# LANGUAGE OverloadedStrings #-}

33module AST.Canonical

44 ( Expr, Expr_(..)

5+ , CaseBranch(..)

56 , Def(..)

6− -- patterns

77 , Args(..), Arg(..)

8− , Match(..)

8+ -- patterns

99 , Pattern, Pattern_(..)

1010 , PatternCtorArg(..)

1111 , Destructors

1212 , Destructor(..)

1313 -- types

14+ , Annotation(..)

1415 , Type(..)

1516 , AliasType(..)

1617 -- decls

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

4142import qualified AST.Utils.Shader as Shader

4243import qualified Data.Index as Index

4344import qualified Elm.Name as N

44−import Elm.Name (Name)

4545import qualified Reporting.Annotation as A

4646import qualified Reporting.Region as R

4747

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

5555

5656

5757data Expr_

58− = VarLocal Name

59− | VarTopLevel ModuleName.Canonical Name

60− | VarKernel Name Name

61− | VarForeign ModuleName.Canonical Name

62− | VarOperator Name ModuleName.Canonical Name

58+ = VarLocal N.Name

59+ | VarTopLevel ModuleName.Canonical N.Name

60+ | VarKernel N.Name N.Name

61+ | VarForeign ModuleName.Canonical N.Name Annotation

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

6363 | Chr Text

6464 | Str Text

6565 | Int Int

6666 | Float Double

6767 | List [Expr]

6868 | Negate Expr

69− | Binop Name ModuleName.Canonical Name Expr Expr

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

7070 | Lambda Args Expr

7171 | Call Expr [Expr]

7272 | If [(Expr, Expr)] Expr

7373 | Let Def Expr

7474 | LetRec [Def] Expr

75− | LetDestruct Match Expr Expr

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

77− | Accessor Name

78− | Access Expr Name

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

80− | Record (Map.Map Name Expr)

75+ | LetDestruct Pattern Destructors Expr Expr

76+ | Case Expr [CaseBranch]

77+ | Accessor N.Name

78+ | Access Expr N.Name

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

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

8181 | Unit

8282 | 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+ }

8493

8594

8695

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

8897

8998

9099data Def =

91− Def

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

93− , _def_args :: Args

94− , _def_body :: Expr

95− , _def_type :: Maybe Type

96− }

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

97101

98102

103+data Args =

104+ Args [Arg] Destructors

99105

100−-- PATTERNS

106+

107+data Arg =

108+ Arg Index.ZeroBased Pattern

101109

102110

103−data Args = Args [Arg] Destructors

104−data Arg = Arg Index.ZeroBased Pattern

105111

106−data Match = Match Pattern Destructors

112+-- PATTERNS

107113

108114

109115type Pattern = A.Located Pattern_

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

149155-- TYPES

150156

151157

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

159+

160+

152161data Type

153162 = TLambda Type Type

154− | TVar Name

155− | TType ModuleName.Canonical Name [Type]

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

163+ | TVar N.Name

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

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

157166 | TUnit

158167 | TTuple Type Type (Maybe Type)

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

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

160169

161170

162171data AliasType

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

175184

176185

177186data Decl

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

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

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

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

180189

181190

182191

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

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

266275

267276

268−instance Binary Binop where

269− get = liftM3 Binop_ get get get

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

277+instance Binary Annotation where

278+ get = liftM2 Forall get get

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

271280

272281

273282instance Binary Type where

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

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

3939

4040data Env =

4141 Env

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

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

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

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

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

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

9696 case exposing of

9797 Open ->

9898 Env

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

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

100100 (Map.unionWith mergeHomes

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

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

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

106106

107107 Explicit explicits ->

108108 Env

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

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

110110 (Map.unionWith mergeHomes

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

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

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

118118toOpenHomes

119119 :: ModuleName.Canonical

120120 -> N.Name

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

122− -> a

123− -> Env.Homes b

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

122+ -> value

123+ -> Env.Homes info

124124toOpenHomes home prefix toInfo value =

125125 let info = toInfo home value in

126126 Env.Homes

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

132132 :: ModuleName.Canonical

133133 -> N.Name

134134 -> Map.Map N.Name Exposed

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

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

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

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

137137 -> N.Name

138− -> a

139− -> Env.Homes b

138+ -> value

139+ -> Env.Homes info

140140toExplicitHomes home prefix explicits toInfo toBag name value =

141141 let info = toInfo home value in

142142 Env.Homes

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

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

145145

146146

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

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

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

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

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

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

150150

151151

152152

153153-- TO INFO

154154

155155

156+{-# INLINE toVarInfo #-}

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

158+toVarInfo =

159+ Env.ForeignVarHome

160+

161+

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

157163toUnionInfo home (Can.Union args _) =

158164 Env.Union (length args) home

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

181187-- TO BAG

182188

183189

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

185−toValueBag info maybeExposed =

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

191+toVarBag info maybeExposed =

186192 case maybeExposed of

187193 Nothing ->

188194 Bag.empty

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

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

55 , Env(..)

66 , VarHomes(..)

77 , UnqualifiedVarHome(..)

8+ , ForeignVarHome(..)

89 , Type(..)

910 , Pattern(..)

1011 , Homes(..)

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

6465 }

6566

6667

68+

69+-- VARIABLES

70+

71+

6772data VarHomes =

6873 VarHomes

6974 { _var_unqualified :: UnqualifiedVarHome

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

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

7176 }

7277

7378

7479data UnqualifiedVarHome

7580 = Local

7681 | TopLevel

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

82+ | Foreign (Bag.Bag ForeignVarHome)

83+

84+

85+data ForeignVarHome =

86+ ForeignVarHome ModuleName.Canonical Can.Annotation

87+

88+

89+

90+-- TYPES

7891

7992

8093data Type

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

8295 | Union Int ModuleName.Canonical

8396

8497

98+

99+-- PATTERNs

100+

101+

85102data Pattern =

86103 Pattern

87104 { _p_home :: ModuleName.Canonical

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

91108 }

92109

93110

111+

112+-- BINOPS

113+

114+

94115data Binop =

95116 Binop

96− { _op_name :: N.Name

117+ { _op :: N.Name

97118 , _op_home :: ModuleName.Canonical

98− , _op_func :: N.Name

119+ , _op_name :: N.Name

120+ , _op_annotation :: Can.Annotation

99121 , _op_associativity :: Binop.Associativity

100122 , _op_precedence :: Binop.Precedence

101123 }

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

141163

142164

143165findVar :: 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 =

145167 case Map.lookup name vars of

146168 Nothing ->

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

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

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

155177

156178 TopLevel ->

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

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

158180

159181 Foreign bag ->

160182 case bag of

161− Bag.One foreignHome ->

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

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

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

163185

164186 Bag.Empty ->

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

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

172194 Nothing ->

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

174196

175− Just (OneOrMore.One foreignHome) ->

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

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

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

177199

178200 Just _ ->

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

src/Canonicalize/Expression.hs+23−22

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

1919import qualified Canonicalize.Pattern as Pattern

2020import qualified Canonicalize.Type as Type

2121import qualified Data.Bag as Bag

22+import qualified Data.Index as Index

2223import qualified Elm.Name as N

2324import qualified Reporting.Annotation as A

2425import qualified Reporting.Error.Canonicalize as Error

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

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

6768

6869 Valid.Op op ->

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

70− return (Can.VarOperator op home name)

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

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

7172

7273 Valid.Negate expr ->

7374 Can.Negate <$> canonicalize env expr

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

9596 Valid.Let defs expr ->

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

9798

98− Valid.Case expr cases ->

99+ Valid.Case expr branches ->

99100 Can.Case

100101 <$> canonicalize env expr

101− <*> traverse (canonicalizeCaseBranch env) cases

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

102103

103104 Valid.Accessor field ->

104105 Result.ok $ Can.Accessor field

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

164165-- CANONICALIZE CASE BRANCH

165166

166167

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

168−canonicalizeCaseBranch env (pattern, expr) =

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

169+canonicalizeCaseBranch env index (pattern, expr) =

169170 addLocals $

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

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

171172 newEnv <- Env.addLocals destructors env

172173 removeLocals Warning.Pattern destructors $

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

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

174175

175176

176177

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

211212 runBinopStepper overallRegion $

212213 toBinopStep (toBinop op expr) op rest final

213214

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

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

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

216217

217218

218219toBinopStep :: (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 =

220221 case middle of

221222 [] ->

222223 Done (makeBinop final)

223224

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

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

225226 if precedence < rootPrecedence then

226227

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

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

252253

253254

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

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

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

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

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

257258

258259

259260

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

316317

317318data Binding

318319 = Define R.Region Can.Def

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

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

320321

321322

322323data Node = Node Binding FreeLocals

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

327328 case binding of

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

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

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

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

331332 newEnv <- Env.addLocals destructors env

332333 toNode defKeys destructors index $

333334 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

335336

336− Pattern.Destruct region index match body ->

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

337338 toNode defKeys Map.empty index $

338− Destruct region match <$> canonicalize env body

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

339340

340341

341342toNode :: 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 =

376377 Result.accumulate freeLocals (Can.Let def)

377378 <*> detectCycles region subSccs body

378379

379− Destruct _ match expr ->

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

380+ Destruct _ pattern destructors expr ->

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

381382 <*> detectCycles region subSccs body

382383

383384 Graph.CyclicSCC nodes ->

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

402403 _ ->

403404 Just (def, freeLocals)

404405

405− Destruct _ _ _ ->

406+ Destruct _ _ _ _ ->

406407 Nothing

407408

408409

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

417418 _ ->

418419 Error.CycleFunc name

419420

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

421+ Destruct _ pattern _ _ ->

421422 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])

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

168168 case args of

169169 [] ->

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

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

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

172172 Expr.canonicalize env body

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

173+ return

174+ ( Value region name cbody annotation

175+ , key

176+ , Set.toList freeLocals

177+ )

174178

175179 _ ->

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

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

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

178182 newEnv <- Env.addLocals destructors env

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

180184 Expr.canonicalize newEnv body

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

185+ return

186+ ( Function key cargs cbody annotation

187+ , key

188+ , Set.toList freeLocals

189+ )

182190

183191

184192data Decl

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

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

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

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

187195

188196

189197toCanDecl :: Decl -> Can.Decl

src/Canonicalize/Pattern.hs+39−40

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

11{-# OPTIONS_GHC -Wall #-}

22module Canonicalize.Pattern

3− ( canonicalizeArgs

4− , canonicalizeMatch

3+ ( canonicalize

4+ , canonicalizeArgs

55 , canonicalizeBindings

66 , Binding(..)

77 )

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

3535

3636

3737

38−-- CANONICALIZE ARGS

38+-- CANONICALIZE

3939

4040

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

42−canonicalizeArgs env patterns =

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

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

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

42+canonicalize env index pattern =

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

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

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

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

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

48− Can.Args args destructors

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

4948

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

5150 Result.Result () warnings (Result.Err err)

5251

5352

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−

5953

60−-- CANONICALIZE MATCH

54+-- CANONICALIZE ARGS

6155

6256

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

64−canonicalizeMatch env pattern =

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

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

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

58+canonicalizeArgs env patterns =

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

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

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

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

6963 Result.Result () warnings $ Result.Ok $

70− Can.Match cpattern destructors

64+ Can.Args args destructors

7165

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

7367 Result.Result () warnings (Result.Err err)

7468

7569

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+

7675

7776-- CANONICALIZE BINDINGS

7877

7978

8079data Binding

8180 = 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

8382

8483

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

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

107106 Define region index aname args body maybeType

108107

109108 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

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

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

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

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

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

114+ Destruct region index cpattern destructors body

116115

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

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

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

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

139138

140139

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

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

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

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

143142 A.A region <$>

144143 case pattern of

145144 Src.PAnything ->

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

164163

165164 Src.PTuple a b cs ->

166165 Can.PTuple

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

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

169− <*> canonicalizeTuple region env destructor cs

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

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

168+ <*> processTuple region env destructor cs

170169

171170 Src.PCtor nameRegion maybePrefix name patterns ->

172171 let

173172 toCanonicalArg index ptrn tipe =

174173 Can.PatternCtorArg index tipe

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

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

176175 in

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

178177 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

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

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

185184

186185 Src.PList patterns ->

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

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

188187

189188 Src.PCons first rest ->

190189 Can.PCons

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

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

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

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

193192

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

195− do cpattern <- canonicalize env destructor ptrn

194+ do cpattern <- process env destructor ptrn

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

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

198197

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

206205 Result.ok (Can.PInt int)

207206

208207

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

210−canonicalizeTuple tupleRegion env destructor extras =

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

209+processTuple tupleRegion env destructor extras =

211210 case extras of

212211 [] ->

213212 Result.ok Nothing

214213

215214 [three] ->

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

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

217216

218217 _ : others ->

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

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

221220

222221

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

224−canonicalizeList env destructor list =

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

223+processList env destructor list =

225224 case list of

226225 [] ->

227226 Result.ok []

228227

229228 pattern : otherPatterns ->

230229 (:)

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

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

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

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

src/Canonicalize/Type.hs+51−1

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

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Canonicalize.Type

4− ( canonicalize

4+ ( toAnnotation

5+ , canonicalize

6+ , addFreeVars

57 )

68 where

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

2931

3032

3133

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+

3244-- CANONICALIZE TYPES

3345

3446

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

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

102114 in

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