decec2d · elk · git.iko.soy

git.iko.soy/elk

Handle qualified/unqualified AST nodes in canonicalization

This commit also introduces AST.Canonical.CtorOpts which caches which constructor optimizations are possible. The two it allows are for: type Height = Height Float type Units = Metric | Imperial It is fine to unbox Height, so it needs no allocations. It is also fine to turn Units into a old fashioned enum, where each option is an int, not an object with an int tag. That one is less obviously helpful, but it is no extra trouble at this point.

commitdecec2df105433b0e8d540674cbfd3b42df6f936 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 10 Jan 2018, 02:10 (9 years ago) parenta57d829

4 files changed+204−159

compare with master

unifiedsplit

src/AST/Canonical.hs+53−48 src/Canonicalize/Expression.hs+89−61 src/Canonicalize/Pattern.hs+24−13 src/Canonicalize/Type.hs+38−37

src/AST/Canonical.hs+53−48

@@ -3,15 +3,12 @@

33module AST.Canonical

44 ( Expr, Expr_(..)

55 , CaseBranch(..)

6+ , CtorOpts(..)

67 -- definitions

78 , Def(..)

89 , Decls(..)

910 -- patterns

1011 , Pattern, Pattern_(..)

11− , CtorAlts(..)

12− , CtorAlt(..)

13− , toAlts

14− , ctorsToAlts

1512 , PatternCtorArg(..)

1613 -- types

1714 , Annotation(..)

@@ -20,8 +17,9 @@ module AST.Canonical

2017 -- modules

2118 , Module(..)

2219 , Alias(..)

23− , Union(..)

2420 , Binop(..)

21+ , Union(..)

22+ , Ctor(..)

2523 , Docs(..)

2624 , Exports(..)

2725 , Export(..)

@@ -50,6 +48,7 @@ cached data with comments like:

5048So it is clear why the data is kept around.

5149-}

5250

51+

5352import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)

5453import Data.Binary

5554import qualified Data.ByteString as B

@@ -79,6 +78,7 @@ data Expr_

7978 | VarTopLevel ModuleName.Canonical N.Name

8079 | VarKernel N.Name N.Name

8180 | VarForeign ModuleName.Canonical N.Name Annotation

81+ | VarCtor CtorOpts ModuleName.Canonical N.Name Index.ZeroBased Annotation

8282 | VarDebug ModuleName.Canonical N.Name Annotation

8383 | VarOperator N.Name ModuleName.Canonical N.Name Annotation -- CACHE real name for optimization

8484 | Chr Text

@@ -150,15 +150,15 @@ data Pattern_

150150 | PCtor

151151 { _p_home :: ModuleName.Canonical

152152 , _p_type :: N.Name

153− , _p_vars :: [N.Name]

154− , _p_alts :: CtorAlts

153+ , _p_union :: Union

155154 , _p_name :: N.Name

156155 , _p_index :: Index.ZeroBased

157156 , _p_args :: [PatternCtorArg]

158157 }

159158 -- CACHE _p_home, _p_type, and _p_vars for type inference

160− -- CACHE _p_alts for exhaustiveness checker

161− -- CACHE _p_id for production code gen

159+ -- CACHE _p_index to replace _p_name in PROD code gen

160+ -- CACHE _p_opts to allocate less in PROD code gen

161+ -- CACHE _p_alts and _p_numAlts for exhaustiveness checker

162162

163163

164164data PatternCtorArg =

@@ -169,41 +169,6 @@ data PatternCtorArg =

169169 }

170170

171171

172−data CtorAlts =

173− CtorAlts

174− { _num :: Int -- CACHE (length _alts) for exhaustiveness

175− , _alts :: [CtorAlt]

176− }

177− deriving (Eq)

178−

179−

180−data CtorAlt =

181− CtorAlt

182− { _ctor :: N.Name

183− , _arity :: Int

184− }

185− deriving (Eq)

186−

187−

188−

189−-- PATTERN CTOR HELPERS

190−

191−

192−toAlts :: [CtorAlt] -> CtorAlts

193−toAlts alts =

194− CtorAlts (length alts) alts

195−

196−

197−ctorsToAlts :: [(N.Name, [Type])] -> CtorAlts

198−ctorsToAlts ctors =

199− CtorAlts (length ctors) (map toAlt ctors)

200−

201−

202−toAlt :: (N.Name, [Type]) -> CtorAlt

203−toAlt (ctor, argTypes) =

204− CtorAlt ctor (length argTypes)

205−

206−

207172

208173-- TYPES

209174

@@ -247,10 +212,29 @@ data Module =

247212

248213

249214data Alias = Alias [N.Name] Type (Maybe [N.Name])

250−data Union = Union [N.Name] [(N.Name, [Type])]

251215data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name

252216

253217

218+data Union =

219+ Union

220+ { _u_vars :: [N.Name]

221+ , _u_alts :: [Ctor]

222+ , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking

223+ , _u_opts :: CtorOpts -- CACHE which optimizations are available

224+ }

225+

226+

227+data CtorOpts

228+ = Normal

229+ | Enum

230+ | Unbox

231+ deriving (Eq, Ord)

232+

233+

234+data Ctor =

235+ Ctor N.Name Index.ZeroBased Int [Type] -- CACHE length args

236+

237+

254238

255239-- DOCS

256240

@@ -311,8 +295,29 @@ instance Binary Alias where

311295

312296

313297instance Binary Union where

314− get = liftM2 Union get get

315− put (Union a b) = put a >> put b

298+ put (Union a b c d) = put a >> put b >> put c >> put d

299+ get = liftM4 Union get get get get

300+

301+

302+instance Binary Ctor where

303+ get = liftM4 Ctor get get get get

304+ put (Ctor a b c d) = put a >> put b >> put c >> put d

305+

306+

307+instance Binary CtorOpts where

308+ put opts =

309+ case opts of

310+ Normal -> putWord8 0

311+ Enum -> putWord8 1

312+ Unbox -> putWord8 2

313+

314+ get =

315+ do n <- getWord8

316+ case n of

317+ 0 -> return Normal

318+ 1 -> return Enum

319+ 2 -> return Unbox

320+ _ -> error "binary encoding of CtorOpts was corrupted"

316321

317322

318323instance Binary Annotation where

@@ -363,4 +368,4 @@ instance Binary AliasType where

363368 case n of

364369 0 -> liftM Holey get

365370 1 -> liftM Filled get

366− _ -> error "Error reading a valid type from serialized string"

371+ _ -> error "binary encoding of AliasType was corrupted"

src/Canonicalize/Expression.hs+89−61

@@ -26,7 +26,6 @@ import qualified Canonicalize.Environment as Env

2626import qualified Canonicalize.Environment.Dups as Dups

2727import qualified Canonicalize.Pattern as Pattern

2828import qualified Canonicalize.Type as Type

29−import qualified Data.Bag as Bag

3029import qualified Data.Index as Index

3130import qualified Data.OneOrMore as OneOrMore

3231import qualified Elm.Name as N

@@ -76,8 +75,15 @@ canonicalize env (A.At region expression) =

7675 Valid.Float float ->

7776 Result.ok (Can.Float float)

7877

79− Valid.Var maybePrefix name ->

80− findVar region env maybePrefix name

78+ Valid.Var varType name ->

79+ case varType of

80+ Src.Value -> findVar region env name

81+ Src.Ctor -> toVarCtor name <$> Env.findCtor region env name

82+

83+ Valid.VarQual varType prefix name ->

84+ case varType of

85+ Src.Value -> findVarQual region env prefix name

86+ Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name

8187

8288 Valid.List exprs ->

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

@@ -134,7 +140,7 @@ canonicalize env (A.At region expression) =

134140

135141 Valid.Update (A.At reg name) fields ->

136142 do fieldDict <- Dups.checkFields fields

137− name_ <- findVar reg env Nothing name

143+ name_ <- findVar reg env name

138144 Can.Update (A.At reg name_)

139145 <$> traverse (canonicalize env) fieldDict

140146

@@ -339,7 +345,10 @@ addBindingsHelp bindings (A.At region pattern) =

339345 Src.PTuple a b cs ->

340346 List.foldl' addBindingsHelp bindings (a:b:cs)

341347

342− Src.PCtor _ _ _ patterns ->

348+ Src.PCtor _ _ patterns ->

349+ List.foldl' addBindingsHelp bindings patterns

350+

351+ Src.PCtorQual _ _ _ patterns ->

343352 List.foldl' addBindingsHelp bindings patterns

344353

345354 Src.PList patterns ->

@@ -458,18 +467,19 @@ addEdge edges nodes aname@(A.At _ name) =

458467getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]

459468getPatternNames names (A.At region pattern) =

460469 case pattern of

461− Src.PAnything -> names

462− Src.PVar name -> A.At region name : names

463− Src.PRecord fields -> fields ++ names

464− Src.PAlias ptrn name -> getPatternNames (name : names) ptrn

465− Src.PUnit -> names

466− Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs

467− Src.PCtor _ _ _ args -> List.foldl' getPatternNames names args

468− Src.PList patterns -> List.foldl' getPatternNames names patterns

469− Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl

470− Src.PChr _ -> names

471− Src.PStr _ -> names

472− Src.PInt _ -> names

470+ Src.PAnything -> names

471+ Src.PVar name -> A.At region name : names

472+ Src.PRecord fields -> fields ++ names

473+ Src.PAlias ptrn name -> getPatternNames (name : names) ptrn

474+ Src.PUnit -> names

475+ Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs

476+ Src.PCtor _ _ args -> List.foldl' getPatternNames names args

477+ Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args

478+ Src.PList patterns -> List.foldl' getPatternNames names patterns

479+ Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl

480+ Src.PChr _ -> names

481+ Src.PStr _ -> names

482+ Src.PInt _ -> names

473483

474484

475485

@@ -674,56 +684,74 @@ delayedUsage (Result.Result k) =

674684-- FIND VARIABLE

675685

676686

677−findVar :: R.Region -> Env.Env -> Maybe N.Name -> N.Name -> Result FreeLocals w Can.Expr_

678−findVar region (Env.Env localHome vars _ _ _) maybePrefix name =

687+findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_

688+findVar region (Env.Env localHome vars _ _ _ _ _ _) name =

679689 case Map.lookup name vars of

680− Nothing ->

681− case maybePrefix of

682− Nothing ->

683− Result.throw (error "TODO no name" region)

690+ Just var ->

691+ case var of

692+ Env.Local _ ->

693+ logVar name (Can.VarLocal name)

684694

685− Just prefix ->

686− if ModuleName.isKernel prefix then

687− Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name

688− else

689− Result.throw (error "TODO no name" region)

695+ Env.TopLevel _ ->

696+ logVar name (Can.VarTopLevel localHome name)

690697

691− Just (Env.VarHomes unqualified qualified) ->

692− case maybePrefix of

693− Nothing ->

694− case unqualified of

695− Env.Local _ ->

696− logVar name (Can.VarLocal name)

697−

698− Env.TopLevel _ ->

699− logVar name (Can.VarTopLevel localHome name)

700−

701− Env.Foreign bag ->

702− case bag of

703− Bag.One (Env.ForeignVarHome home annotation) ->

704− Result.ok $

705− if home == ModuleName.debug then

706− Can.VarDebug localHome name annotation

707− else

708− Can.VarForeign home name annotation

709−

710− Bag.Empty ->

711− Result.throw (error "TODO no unqualified" region)

712−

713− Bag.Two _ _ ->

714− Result.throw (error "TODO ambiguous unqualified" region)

715−

716− Just prefix ->

717− case Map.lookup prefix qualified of

718− Nothing ->

719− Result.throw (error "TODO no qualified" region)

720−

721− Just (OneOrMore.One (Env.ForeignVarHome home annotation)) ->

698+ Env.Foreign bag ->

699+ case bag of

700+ OneOrMore.One (Env.ForeignVar home annotation) ->

722701 Result.ok $

723702 if home == ModuleName.debug then

724703 Can.VarDebug localHome name annotation

725704 else

726705 Can.VarForeign home name annotation

727706

728− Just _ ->

729− Result.throw (error "TODO ambiguous qualified" region)

707+ OneOrMore.More _ _ ->

708+ Result.throw (error "TODO ambiguous unqualified" region)

709+

710+ Nothing ->

711+ Result.throw (error "TODO no name" region)

712+

713+

714+findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_

715+findVarQual region (Env.Env localHome _ _ _ _ vars _ _) prefix name =

716+ case Map.lookup prefix vars of

717+ Just qualified ->

718+ case Map.lookup name qualified of

719+ Just (OneOrMore.One (Env.ForeignVar home annotation)) ->

720+ Result.ok $

721+ if home == ModuleName.debug then

722+ Can.VarDebug localHome name annotation

723+ else

724+ Can.VarForeign home name annotation

725+

726+ Just _ ->

727+ Result.throw (error "TODO ambiguous qualified" region)

728+

729+ Nothing ->

730+ Result.throw (error "TODO no qualified" region)

731+

732+ Nothing ->

733+ if ModuleName.isKernel prefix then

734+ Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name

735+ else

736+ Result.throw (error "TODO no name" region)

737+

738+

739+-- FIND CTOR

740+

741+

742+toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_

743+toVarCtor name ctor =

744+ case ctor of

745+ Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->

746+ let

747+ freeVars = Map.fromList (map (\v -> (v, ())) vars)

748+ result = Can.TType home typeName (map Can.TVar vars)

749+ tipe = foldr Can.TLambda result args

750+ in

751+ Can.VarCtor opts home name index (Can.Forall freeVars tipe)

752+

753+ Env.RecordCtor home vars tipe ->

754+ let

755+ freeVars = Map.fromList (map (\v -> (v, ())) vars)

756+ in

757+ Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe)

src/Canonicalize/Pattern.hs+24−13

@@ -84,20 +84,11 @@ canonicalize env (A.At region pattern) =

8484 <*> canonicalize env b

8585 <*> canonicalizeTuple region env cs

8686

87− Src.PCtor nameRegion maybePrefix name patterns ->

88− let

89− toCanonicalArg index ptrn tipe =

90− Can.PatternCtorArg index tipe

91− <$> canonicalize env ptrn

92− in

93− do (Env.Pattern home tipe vars alts index args) <- Env.findPattern nameRegion env maybePrefix name

94− verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

95− case verifiedList of

96− Index.LengthMatch cargs ->

97− Result.ok (Can.PCtor home tipe vars alts name index cargs)

87+ Src.PCtor nameRegion name patterns ->

88+ canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name

9889

99− Index.LengthMismatch actualLength expectedLength ->

100− Result.throw (error "TODO" region actualLength expectedLength)

90+ Src.PCtorQual nameRegion home name patterns ->

91+ canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name

10192

10293 Src.PList patterns ->

10394 Can.PList <$> canonicalizeList env patterns

@@ -121,6 +112,26 @@ canonicalize env (A.At region pattern) =

121112 Result.ok (Can.PInt int)

122113

123114

115+canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_

116+canonicalizeCtor env region name patterns ctor =

117+ case ctor of

118+ Env.Ctor home tipe union index args ->

119+ let

120+ toCanonicalArg argIndex argPattern argTipe =

121+ Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern

122+ in

123+ do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124+ case verifiedList of

125+ Index.LengthMatch cargs ->

126+ Result.ok (Can.PCtor home tipe union name index cargs)

127+

128+ Index.LengthMismatch actualLength expectedLength ->

129+ Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)

130+

131+ Env.RecordCtor _ _ _ ->

132+ Result.throw (Error.PatternHasRecordCtor region name)

133+

134+

124135canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)

125136canonicalizeTuple tupleRegion env extras =

126137 case extras of

src/Canonicalize/Type.hs+38−37

@@ -7,6 +7,7 @@ module Canonicalize.Type

77 where

10+import qualified Data.List as List

1011import qualified Data.Map as Map

1112

1213import qualified AST.Canonical as Can

@@ -35,7 +36,7 @@ type Result i w a =

3536toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation

3637toAnnotation env srcType =

3738 do tipe <- canonicalize env srcType

38− Result.ok $ Can.Forall (addFreeVars tipe Map.empty) tipe

39+ Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe

3940

4041

4142

@@ -48,17 +49,13 @@ canonicalize env (A.At typeRegion tipe) =

4849 Src.TVar x ->

4950 Result.ok (Can.TVar x)

5051

51− Src.TType region maybePrefix name args ->

52− do info <- Env.findType region env maybePrefix name

53− cargs <- traverse (canonicalize env) args

54− case info of

55− Env.Alias arity home argNames aliasedType ->

56− checkArgs Error.AliasArgs arity typeRegion name args $

57− Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType)

52+ Src.TType region name args ->

53+ canonicalizeType env typeRegion name args =<<

54+ Env.findType region env name

5855

59− Env.Union arity home ->

60− checkArgs Error.UnionArgs arity typeRegion name args $

61− Can.TType home name cargs

56+ Src.TTypeQual region home name args ->

57+ canonicalizeType env typeRegion name args =<<

58+ Env.findTypeQual region env home name

6259

6360 Src.TLambda a b ->

6461 Can.TLambda

@@ -68,7 +65,7 @@ canonicalize env (A.At typeRegion tipe) =

6865 Src.TRecord fields ext ->

6966 do fieldDict <- Dups.checkFields fields

7067 Can.TRecord

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

68+ <$> traverse (canonicalize env) fieldDict

7269 <*> traverse (canonicalize env) ext

7370

7471 Src.TUnit ->

@@ -91,59 +88,63 @@ canonicalize env (A.At typeRegion tipe) =

9188

9289

9390

94−-- CHECK ARGS

91+-- CANONICALIZE TYPE

9592

9693

97−checkArgs :: Error.Args -> Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer

98−checkArgs argsType expected region name args answer =

94+canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type

95+canonicalizeType env region name args info =

96+ do cargs <- traverse (canonicalize env) args

97+ case info of

98+ Env.Alias arity home argNames aliasedType ->

99+ checkArity arity region name args $

100+ Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType)

101+

102+ Env.Union arity home ->

103+ checkArity arity region name args $

104+ Can.TType home name cargs

105+

106+

107+checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer

108+checkArity expected region name args answer =

99109 let actual = length args in

100110 if expected == actual then

101111 Result.ok answer

102112 else

103− Result.throw $

104− if actual < expected then

105− Error.TooFew region argsType name expected actual

106− else

107− let

108− extras = drop expected args

109− (A.At start _, A.At end _) = (head extras, last extras)

110− in

111− Error.TooMany region argsType name expected actual (R.merge start end)

113+ Result.throw (Error.BadArity region Error.TypeArity name expected actual)

112114

113115

114116

115117-- ADD FREE VARS

116118

117119

118−addFreeVars :: Can.Type -> Map.Map N.Name () -> Map.Map N.Name ()

119−addFreeVars tipe freeVars =

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

121+addFreeVars freeVars tipe =

120122 case tipe of

121123 Can.TLambda arg result ->

122− addFreeVars arg (addFreeVars result freeVars)

124+ addFreeVars (addFreeVars freeVars result) arg

123125

124126 Can.TVar var ->

125127 Map.insert var () freeVars

126128

127129 Can.TType _ _ args ->

128− foldr addFreeVars freeVars args

130+ List.foldl' addFreeVars freeVars args

129131

130132 Can.TRecord fields Nothing ->

131− Map.foldr addFreeVars freeVars fields

133+ Map.foldl addFreeVars freeVars fields

132134

133135 Can.TRecord fields (Just ext) ->

134− addFreeVars ext (Map.foldr addFreeVars freeVars fields)

136+ Map.foldl addFreeVars (addFreeVars freeVars ext) fields

135137

136138 Can.TUnit ->

137139 freeVars

138140

139141 Can.TTuple a b maybeC ->

140− addFreeVars a $ addFreeVars b $

141− case maybeC of

142− Nothing ->

143− freeVars

142+ case maybeC of

143+ Nothing ->

144+ addFreeVars (addFreeVars freeVars a) b

144145

145− Just c ->

146− addFreeVars c freeVars

146+ Just c ->

147+ addFreeVars (addFreeVars (addFreeVars freeVars a) b) c

147148

148149 Can.TAlias _ _ args _ ->

149− foldr addFreeVars freeVars (map snd args)

150+ List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args