git.iko.soy/elk
on master help sign in
Move code for instantiating source types into Type.Type
40e0c37Evan Czaplicki
src/Type/Environment.hsdeleted−217
compare with master
unifiedsplit
@@ -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
19 , nameToFlex
19 , nameToFlex
20 , nameToRigid
20 , nameToRigid
21 , toSrcType
21 , toSrcType
22+ , fromFlexSrcType
23+ , fromRigidSrcType
22 )
24 )
23 where
25 where
24
26
@@ -26,13 +28,15 @@ import Control.Monad.State.Strict (StateT, liftIO)
26import qualified Control.Monad.State.Strict as State
28import qualified Control.Monad.State.Strict as State
27import qualified Data.Char as Char
29import qualified Data.Char as Char
28import qualified Data.Map.Strict as Map
30import qualified Data.Map.Strict as Map
31+import Data.Map.Strict ((!))
29import Data.Monoid ((<>))
32import Data.Monoid ((<>))
30import qualified Data.Text as Text
33import qualified Data.Text as Text
31import Data.Text (Text)
34import Data.Text (Text)
32import Data.Word (Word32)
35import Data.Word (Word32)
33
36
37+import qualified AST.Module.Name as ModuleName
34import qualified AST.Type as T
38import qualified AST.Type as T
35−import qualified AST.Variable as Var
39+import qualified Elm.Name as N
36import qualified Type.UnionFind as UF
40import qualified Type.UnionFind as UF
37
41
38
42
@@ -45,20 +49,24 @@ type Variable =
45
49
46
50
47data FlatType
51data FlatType
48− = App1 Var.Canonical [Variable]
52+ = App1 ModuleName.Canonical N.Name [Variable]
49 | Fun1 Variable Variable
53 | Fun1 Variable Variable
50 | EmptyRecord1
54 | EmptyRecord1
51 | Record1 (Map.Map Text Variable) Variable
55 | Record1 (Map.Map Text Variable) Variable
56+ | Unit1
57+ | Tuple1 Variable Variable [Variable]
52
58
53
59
54data Type
60data Type
55 = PlaceHolder Text
61 = PlaceHolder Text
56− | AliasN Var.Canonical [(Text, Type)] Type
62+ | AliasN ModuleName.Canonical N.Name [(Text, Type)] Type
57 | VarN Variable
63 | VarN Variable
58− | AppN Var.Canonical [Type]
64+ | AppN ModuleName.Canonical N.Name [Type]
59 | FunN Type Type
65 | FunN Type Type
60 | EmptyRecordN
66 | EmptyRecordN
61 | RecordN (Map.Map Text Type) Type
67 | RecordN (Map.Map Text Type) Type
68+ | UnitN
69+ | TupleN Type Type [Type]
62
70
63
71
64
72
@@ -80,7 +88,7 @@ data Content
80 | RigidVar Text
88 | RigidVar Text
81 | RigidSuper T.Super Text
89 | RigidSuper T.Super Text
82 | Structure FlatType
90 | Structure FlatType
83− | Alias Var.Canonical [(Text,Variable)] Variable
91+ | Alias ModuleName.Canonical N.Name [(Text,Variable)] Variable
84 | Error Text
92 | Error Text
85
93
86
94
@@ -148,25 +156,25 @@ infixr 9 ==>
148{-# NOINLINE float #-}
156{-# NOINLINE float #-}
149float :: Type
157float :: Type
150float =
158float =
151− AppN Var.float []
159+ AppN ModuleName.basics "Float" []
152
160
153
161
154{-# NOINLINE char #-}
162{-# NOINLINE char #-}
155char :: Type
163char :: Type
156char =
164char =
157− AppN Var.char []
165+ AppN ModuleName.basics "Char" []
158
166
159
167
160{-# NOINLINE string #-}
168{-# NOINLINE string #-}
161string :: Type
169string :: Type
162string =
170string =
163− AppN Var.string []
171+ AppN ModuleName.basics "String" []
164
172
165
173
166{-# NOINLINE bool #-}
174{-# NOINLINE bool #-}
167bool :: Type
175bool :: Type
168bool =
176bool =
169− AppN Var.bool []
177+ AppN ModuleName.basics "Bool" []
170
178
171
179
172
180
@@ -214,19 +222,19 @@ unnamedFlexSuper super =
214-- MAKE NAMED VARIABLES
222-- MAKE NAMED VARIABLES
215
223
216
224
217−nameToFlex :: Text -> IO Variable
225+nameToFlex :: N.Name -> IO Variable
218nameToFlex name =
226nameToFlex name =
219 UF.fresh $ makeDescriptor $
227 UF.fresh $ makeDescriptor $
220 maybe FlexVar FlexSuper (toSuper name) (Just name)
228 maybe FlexVar FlexSuper (toSuper name) (Just name)
221
229
222
230
223−nameToRigid :: Text -> IO Variable
231+nameToRigid :: N.Name -> IO Variable
224nameToRigid name =
232nameToRigid name =
225 UF.fresh $ makeDescriptor $
233 UF.fresh $ makeDescriptor $
226 maybe RigidVar RigidSuper (toSuper name) name
234 maybe RigidVar RigidSuper (toSuper name) name
227
235
228
236
229−toSuper :: Text -> Maybe T.Super
237+toSuper :: N.Name -> Maybe T.Super
230toSuper name =
238toSuper name =
231 if Text.isPrefixOf "number" name then
239 if Text.isPrefixOf "number" name then
232 Just T.Number
240 Just T.Number
@@ -245,7 +253,105 @@ toSuper name =
245
253
246
254
247
255
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+
248−-- CONVERT TO SOURCE TYPES
354+-- TO SOURCE TYPES
249
355
250
356
251-- TODO: Attach resulting type to the descriptor so that you
357-- TODO: Attach resulting type to the descriptor so that you
@@ -303,10 +409,10 @@ contentToSrcType variable content =
303 RigidSuper _ name ->
409 RigidSuper _ name ->
304 return (T.Var name)
410 return (T.Var name)
305
411
306− Alias name args realVariable ->
412+ Alias home name args realVariable ->
307 do srcArgs <- traverse (traverse variableToSrcType) args
413 do srcArgs <- traverse (traverse variableToSrcType) args
308 srcType <- variableToSrcType realVariable
414 srcType <- variableToSrcType realVariable
309− return (T.Aliased name srcArgs (T.Filled srcType))
415+ return (T.Aliased home name srcArgs (T.Filled srcType))
310
416
311 Error name ->
417 Error name ->
312 return (T.Var name)
418 return (T.Var name)
@@ -315,8 +421,8 @@ contentToSrcType variable content =
315termToSrcType :: FlatType -> StateT NameState IO T.Canonical
421termToSrcType :: FlatType -> StateT NameState IO T.Canonical
316termToSrcType term =
422termToSrcType term =
317 case term of
423 case term of
318− App1 name args ->
424+ App1 home name args ->
319− T.Type name <$> traverse variableToSrcType args
425+ T.Type home name <$> traverse variableToSrcType args
320
426
321 Fun1 a b ->
427 Fun1 a b ->
322 T.Lambda
428 T.Lambda
@@ -324,15 +430,15 @@ termToSrcType term =
324 <*> variableToSrcType b
430 <*> variableToSrcType b
325
431
326 EmptyRecord1 ->
432 EmptyRecord1 ->
327− return $ T.Record [] Nothing
433+ return $ T.Record Map.empty Nothing
328
434
329 Record1 fields extension ->
435 Record1 fields extension ->
330− do srcFields <- Map.toList <$> traverse variableToSrcType fields
436+ do srcFields <- traverse variableToSrcType fields
331 srcExt <- T.iteratedDealias <$> variableToSrcType extension
437 srcExt <- T.iteratedDealias <$> variableToSrcType extension
332 return $
438 return $
333 case srcExt of
439 case srcExt of
334 T.Record subFields subExt ->
440 T.Record subFields subExt ->
335− T.Record (subFields ++ srcFields) subExt
441+ T.Record (Map.union subFields srcFields) subExt
336
442
337 T.Var _ ->
443 T.Var _ ->
338 T.Record srcFields (Just srcExt)
444 T.Record srcFields (Just srcExt)
@@ -340,6 +446,15 @@ termToSrcType term =
340 _ ->
446 _ ->
341 error "Used toSrcType on a type that is not well-formed"
447 error "Used toSrcType on a type that is not well-formed"
342
448
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+
343
458
344
459
345-- MANAGE FRESH VARIABLE NAMES
460-- MANAGE FRESH VARIABLE NAMES
@@ -470,23 +585,33 @@ getVarNames var =
470 RigidSuper super name ->
585 RigidSuper super name ->
471 registerName name var (RigidSuper super)
586 registerName name var (RigidSuper super)
472
587
473− Alias _ args realVar ->
588+ Alias _ _ args realVar ->
474 do mapM_ (getVarNames . snd) args
589 do mapM_ (getVarNames . snd) args
475 getVarNames realVar
590 getVarNames realVar
476
591
477− Structure (App1 _ args) ->
592+ Structure flatType ->
593+ case flatType of
594+ App1 _ _ args ->
478− mapM_ getVarNames args
595+ mapM_ getVarNames args
479
596
480− Structure (Fun1 arg body) ->
597+ Fun1 arg body ->
481− do getVarNames arg
598+ do getVarNames arg
482− getVarNames body
599+ getVarNames body
483
600
484− Structure EmptyRecord1 ->
601+ EmptyRecord1 ->
602+ return ()
603+
604+ Record1 fields extension ->
605+ do mapM_ getVarNames fields
606+ getVarNames extension
607+
608+ Unit1 ->
485− return ()
609+ return ()
486
610
487− Structure (Record1 fields extension) ->
611+ Tuple1 a b cs ->
612+ do getVarNames a
613+ getVarNames b
488− do mapM_ getVarNames fields
614+ mapM_ getVarNames cs
489− getVarNames extension
490
615
491
616
492
617