40e0c37 · elk · git.iko.soy

git.iko.soy/elk

Move code for instantiating source types into Type.Type

The new implementation has a tail recursive gatherFreeVars function. The idea is that you can avoid StateT with that, hopefully reducing allocations overall. This means the source type will get crawled twice though.

commit40e0c37cf8d0bab433b2335ecf5cfdb7bd0bd746 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 1 Nov 2017, 15:43 (9 years ago) parent4d68518

2 files changed+156−248

compare with master

unifiedsplit

src/Type/Environment.hs−217 src/Type/Type.hs+156−31

src/Type/Environment.hsdeleted−217

@@ -1,217 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Type.Environment

4− ( Env

5− , Dict

6− , initialize

7− , get, freshDataScheme, ctorNames

8− , addValues

9− , instantiateFlex

10− , instantiateRigid

11− )

12− where

13−

14−import qualified Control.Monad.State.Strict as State

15−import qualified Data.List as List

16−import qualified Data.Map.Strict as Map

17−import qualified Data.Set as Set

18−import Data.Text (Text)

19−

20−import qualified AST.Helpers as Help

21−import qualified AST.Type as T

22−import qualified AST.Variable as Var

23−import qualified AST.Module as Module

24−import Type.Type

25−

26−

27−

28−-- ENVIRONMENT

29−

30−

31−data Env =

32− Env

33− { _ctor :: Dict Instantiator

34− , _value :: Dict Type

35− }

36−

37−

38−type Instantiator =

39− IO (Int, [Variable], [Type], Type)

40−

41−

42−type Dict a =

43− Map.Map Text a

44−

45−

46−initialize :: [Module.CanonicalUnion] -> Env

47−initialize unions =

48− Env (makeCtors unions) Map.empty

49−

50−

51−

52−-- CONSTRUCTORS

53−

54−

55−makeCtors :: [Module.CanonicalUnion] -> Dict Instantiator

56−makeCtors unions =

57− let

58− list t =

59− AppN Var.list [t]

60−

61− inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator

62− inst numTVars tipe =

63− do vars <- mapM (\_ -> mkFlexVar) [1..numTVars]

64− let (args, result) = tipe (map (VarN) vars)

65− return (length args, vars, args, result)

66−

67− tupleCtor size =

68− let

69− name =

70− Help.makeTuple size

71− in

72− (name, inst size $ \vs -> (vs, AppN (Var.tuple size) vs))

73−

74− builtins :: Dict Instantiator

75− builtins =

76− Map.fromList $

77− [ ("[]", inst 1 $ \ [t] -> ([], list t))

78− , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

79− ]

80− ++ map tupleCtor [0..9]

81− in

82− List.foldl' makeCtorsHelp builtins unions

83−

84−

85−type VarDict =

86− Map.Map Text Variable

87−

88−

89−makeCtorsHelp :: Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator

90−makeCtorsHelp constructorDict ( var, (rawTypeVars, ctors) ) =

91− let

92− inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator

93− inst ctorDict (name, rawArgs) =

94− Map.insert

95− (Var.toText name)

96− ( do ((args, tipe), dict) <- State.runStateT (go rawArgs) Map.empty

97− return ( length args, Map.elems dict, args, tipe )

98− )

99− ctorDict

100−

101− tvars =

102− map T.Var rawTypeVars

103−

104− go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)

105− go args =

106− do types <- mapM (instantiator nameToFlex Map.empty) args

107− returnType <- instantiator nameToFlex Map.empty (T.Type var tvars)

108− return (types, returnType)

109− in

110− List.foldl' inst constructorDict ctors

111−

112−

113−

114−-- ACCESS TYPES

115−

116−

117−{-# INLINE get #-}

118−get :: Dict a -> Text -> a

119−get dict var =

120− dict Map.! var

121−

122−

123−freshDataScheme :: Env -> Text -> Instantiator

124−freshDataScheme env var =

125− get (_ctor env) var

126−

127−

128−ctorNames :: Env -> [Text]

129−ctorNames env =

130− Map.keys (_ctor env)

131−

132−

133−

134−-- UPDATE ENVIRONMENT

135−

136−

137−addValues :: VarDict -> Env -> Env

138−addValues newValues env =

139− env { _value = Map.union (_value env) (Map.map VarN newValues) }

140−

141−

142−

143−-- INSTANTIATE TYPES

144−

145−

146−instantiateFlex :: Env -> T.Canonical -> IO (Type, VarDict)

147−instantiateFlex env sourceType =

148− State.runStateT (instantiator nameToFlex (_value env) sourceType) Map.empty

149−

150−

151−instantiateRigid :: Env -> T.Canonical -> IO (Type, VarDict)

152−instantiateRigid env sourceType =

153− State.runStateT (instantiator nameToRigid (_value env) sourceType) Map.empty

154−

155−

156−instantiator :: (Text -> IO Variable) -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type

157−instantiator nameToVar values sourceType =

158− instantiatorHelp nameToVar values Set.empty sourceType

159−

160−

161−instantiatorHelp :: (Text -> IO Variable) -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type

162−instantiatorHelp nameToVar values aliasVars sourceType =

163− {-# SCC elm_compiler_type_instantiate #-}

164− let

165− go =

166− instantiatorHelp nameToVar values aliasVars

167− in

168− case sourceType of

169− T.Lambda t1 t2 ->

170− FunN <$> go t1 <*> go t2

171−

172− T.Var name ->

173− if Set.member name aliasVars then

174− return (PlaceHolder name)

175−

176− else

177− case Map.lookup name values of

178− Just tipe ->

179− return tipe

180−

181− Nothing ->

182− do dict <- State.get

183− case Map.lookup name dict of

184− Just variable ->

185− return (VarN variable)

186−

187− Nothing ->

188− do variable <- State.liftIO (nameToVar name)

189− State.put (Map.insert name variable dict)

190− return (VarN variable)

191−

192− T.Aliased name args aliasType ->

193− do targs <- traverse (traverse go) args

194− realType <-

195− case aliasType of

196− T.Filled tipe ->

197− instantiatorHelp nameToVar values Set.empty tipe

198−

199− T.Holey tipe ->

200− instantiatorHelp nameToVar values (Set.fromList (map fst args)) tipe

201−

202− return (AliasN name targs realType)

203−

204− T.Type name args ->

205− AppN name <$> traverse go args

206−

207− T.Record fields ext ->

208− do tfields <- traverse go (Map.fromList fields)

209− text <-

210− case ext of

211− Nothing ->

212− return EmptyRecordN

213−

214− Just extType ->

215− go extType

216−

217− return $ RecordN tfields text

src/Type/Type.hs+156−31

@@ -19,6 +19,8 @@ module Type.Type

1919 , nameToFlex

2020 , nameToRigid

2121 , toSrcType

22+ , fromFlexSrcType

23+ , fromRigidSrcType

2224 )

2325 where

2426

@@ -26,13 +28,15 @@ import Control.Monad.State.Strict (StateT, liftIO)

2628import qualified Control.Monad.State.Strict as State

2729import qualified Data.Char as Char

2830import qualified Data.Map.Strict as Map

31+import Data.Map.Strict ((!))

2932import Data.Monoid ((<>))

3033import qualified Data.Text as Text

3134import Data.Text (Text)

3235import Data.Word (Word32)

3336

37+import qualified AST.Module.Name as ModuleName

3438import qualified AST.Type as T

35−import qualified AST.Variable as Var

39+import qualified Elm.Name as N

3640import qualified Type.UnionFind as UF

3741

3842

@@ -45,20 +49,24 @@ type Variable =

4549

4650

4751data FlatType

48− = App1 Var.Canonical [Variable]

52+ = App1 ModuleName.Canonical N.Name [Variable]

4953 | Fun1 Variable Variable

5054 | EmptyRecord1

5155 | Record1 (Map.Map Text Variable) Variable

56+ | Unit1

57+ | Tuple1 Variable Variable [Variable]

5258

5359

5460data Type

5561 = PlaceHolder Text

56− | AliasN Var.Canonical [(Text, Type)] Type

62+ | AliasN ModuleName.Canonical N.Name [(Text, Type)] Type

5763 | VarN Variable

58− | AppN Var.Canonical [Type]

64+ | AppN ModuleName.Canonical N.Name [Type]

5965 | FunN Type Type

6066 | EmptyRecordN

6167 | RecordN (Map.Map Text Type) Type

68+ | UnitN

69+ | TupleN Type Type [Type]

6270

6371

6472

@@ -80,7 +88,7 @@ data Content

8088 | RigidVar Text

8189 | RigidSuper T.Super Text

8290 | Structure FlatType

83− | Alias Var.Canonical [(Text,Variable)] Variable

91+ | Alias ModuleName.Canonical N.Name [(Text,Variable)] Variable

8492 | Error Text

8593

8694

@@ -148,25 +156,25 @@ infixr 9 ==>

148156{-# NOINLINE float #-}

149157float :: Type

150158float =

151− AppN Var.float []

159+ AppN ModuleName.basics "Float" []

152160

153161

154162{-# NOINLINE char #-}

155163char :: Type

156164char =

157− AppN Var.char []

165+ AppN ModuleName.basics "Char" []

158166

159167

160168{-# NOINLINE string #-}

161169string :: Type

162170string =

163− AppN Var.string []

171+ AppN ModuleName.basics "String" []

164172

165173

166174{-# NOINLINE bool #-}

167175bool :: Type

168176bool =

169− AppN Var.bool []

177+ AppN ModuleName.basics "Bool" []

170178

171179

172180

@@ -214,19 +222,19 @@ unnamedFlexSuper super =

214222-- MAKE NAMED VARIABLES

215223

216224

217−nameToFlex :: Text -> IO Variable

225+nameToFlex :: N.Name -> IO Variable

218226nameToFlex name =

219227 UF.fresh $ makeDescriptor $

220228 maybe FlexVar FlexSuper (toSuper name) (Just name)

221229

222230

223−nameToRigid :: Text -> IO Variable

231+nameToRigid :: N.Name -> IO Variable

224232nameToRigid name =

225233 UF.fresh $ makeDescriptor $

226234 maybe RigidVar RigidSuper (toSuper name) name

227235

228236

229−toSuper :: Text -> Maybe T.Super

237+toSuper :: N.Name -> Maybe T.Super

230238toSuper name =

231239 if Text.isPrefixOf "number" name then

232240 Just T.Number

@@ -245,7 +253,105 @@ toSuper name =

245253

246254

247255

248−-- CONVERT TO SOURCE TYPES

256+-- FROM SOURCE TYPES

257+

258+

259+-- TODO should the freeFlexVars be ranked a certain way?

260+-- How does this interact with `TS.flatten` exactly?

261+fromFlexSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )

262+fromFlexSrcType srcType =

263+ do let freeVars = gatherFreeVars srcType Map.empty

264+ freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars

265+ tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType

266+ return ( tipe, freeFlexVars )

267+

268+

269+fromRigidSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )

270+fromRigidSrcType srcType =

271+ do let freeVars = gatherFreeVars srcType Map.empty

272+ freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars

273+ tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType

274+ return ( tipe, freeRigidVars )

275+

276+

277+gatherFreeVars :: T.Canonical -> Map.Map N.Name () -> Map.Map N.Name ()

278+gatherFreeVars tipe dict =

279+ case tipe of

280+ T.Lambda arg result ->

281+ gatherFreeVars result (gatherFreeVars arg dict)

282+

283+ T.Var name ->

284+ Map.insert name () dict

285+

286+ T.Type _ _ args ->

287+ foldr gatherFreeVars dict args

288+

289+ T.Aliased _ _ args _ ->

290+ foldr gatherFreeVars dict (map snd args)

291+

292+ T.Tuple a b cs ->

293+ gatherFreeVars a $ gatherFreeVars b $

294+ foldr gatherFreeVars dict cs

295+

296+ T.Unit ->

297+ dict

298+

299+ T.Record fields maybeExt ->

300+ case maybeExt of

301+ Nothing ->

302+ Map.foldr gatherFreeVars dict fields

303+

304+ Just ext ->

305+ Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields

306+

307+

308+fromSrcType :: Map.Map N.Name Type -> T.Canonical -> IO Type

309+fromSrcType freeVars sourceType =

310+ case sourceType of

311+ T.Lambda arg result ->

312+ FunN

313+ <$> fromSrcType freeVars arg

314+ <*> fromSrcType freeVars result

315+

316+ T.Var name ->

317+ return (freeVars ! name)

318+

319+ T.Type home name args ->

320+ AppN home name <$> traverse (fromSrcType freeVars) args

321+

322+ T.Aliased home name args aliasedType ->

323+ do targs <- traverse (traverse (fromSrcType freeVars)) args

324+ AliasN home name targs <$>

325+ case aliasedType of

326+ T.Filled realType ->

327+ fromSrcType freeVars realType

328+

329+ T.Holey realType ->

330+ fromSrcType (Map.fromList targs) realType

331+

332+ T.Tuple a b cs ->

333+ TupleN

334+ <$> fromSrcType freeVars a

335+ <*> fromSrcType freeVars b

336+ <*> traverse (fromSrcType freeVars) cs

337+

338+ T.Unit ->

339+ return UnitN

340+

341+ T.Record fields maybeExt ->

342+ RecordN

343+ <$> traverse (fromSrcType freeVars) fields

344+ <*>

345+ case maybeExt of

346+ Nothing ->

347+ return EmptyRecordN

348+

349+ Just ext ->

350+ fromSrcType freeVars ext

351+

352+

353+

354+-- TO SOURCE TYPES

249355

250356

251357-- TODO: Attach resulting type to the descriptor so that you

@@ -303,10 +409,10 @@ contentToSrcType variable content =

303409 RigidSuper _ name ->

304410 return (T.Var name)

305411

306− Alias name args realVariable ->

412+ Alias home name args realVariable ->

307413 do srcArgs <- traverse (traverse variableToSrcType) args

308414 srcType <- variableToSrcType realVariable

309− return (T.Aliased name srcArgs (T.Filled srcType))

415+ return (T.Aliased home name srcArgs (T.Filled srcType))

310416

311417 Error name ->

312418 return (T.Var name)

@@ -315,8 +421,8 @@ contentToSrcType variable content =

315421termToSrcType :: FlatType -> StateT NameState IO T.Canonical

316422termToSrcType term =

317423 case term of

318− App1 name args ->

319− T.Type name <$> traverse variableToSrcType args

424+ App1 home name args ->

425+ T.Type home name <$> traverse variableToSrcType args

320426

321427 Fun1 a b ->

322428 T.Lambda

@@ -324,15 +430,15 @@ termToSrcType term =

324430 <*> variableToSrcType b

325431

326432 EmptyRecord1 ->

327− return $ T.Record [] Nothing

433+ return $ T.Record Map.empty Nothing

328434

329435 Record1 fields extension ->

330− do srcFields <- Map.toList <$> traverse variableToSrcType fields

436+ do srcFields <- traverse variableToSrcType fields

331437 srcExt <- T.iteratedDealias <$> variableToSrcType extension

332438 return $

333439 case srcExt of

334440 T.Record subFields subExt ->

335− T.Record (subFields ++ srcFields) subExt

441+ T.Record (Map.union subFields srcFields) subExt

336442

337443 T.Var _ ->

338444 T.Record srcFields (Just srcExt)

@@ -340,6 +446,15 @@ termToSrcType term =

340446 _ ->

341447 error "Used toSrcType on a type that is not well-formed"

342448

449+ Unit1 ->

450+ return T.Unit

451+

452+ Tuple1 a b cs ->

453+ T.Tuple

454+ <$> variableToSrcType a

455+ <*> variableToSrcType b

456+ <*> traverse variableToSrcType cs

457+

343458

344459

345460-- MANAGE FRESH VARIABLE NAMES

@@ -470,23 +585,33 @@ getVarNames var =

470585 RigidSuper super name ->

471586 registerName name var (RigidSuper super)

472587

473− Alias _ args realVar ->

588+ Alias _ _ args realVar ->

474589 do mapM_ (getVarNames . snd) args

475590 getVarNames realVar

476591

477− Structure (App1 _ args) ->

478− mapM_ getVarNames args

592+ Structure flatType ->

593+ case flatType of

594+ App1 _ _ args ->

595+ mapM_ getVarNames args

479596

480− Structure (Fun1 arg body) ->

481− do getVarNames arg

482− getVarNames body

597+ Fun1 arg body ->

598+ do getVarNames arg

599+ getVarNames body

483600

484− Structure EmptyRecord1 ->

485− return ()

601+ EmptyRecord1 ->

602+ return ()

603+

604+ Record1 fields extension ->

605+ do mapM_ getVarNames fields

606+ getVarNames extension

607+

608+ Unit1 ->

609+ return ()

486610

487− Structure (Record1 fields extension) ->

488− do mapM_ getVarNames fields

489− getVarNames extension

611+ Tuple1 a b cs ->

612+ do getVarNames a

613+ getVarNames b

614+ mapM_ getVarNames cs

490615

491616

492617