git.iko.soy/elk
on bca019d help sign in
elk/src/Type/Environment.hs
217 lines 5.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Environment
4 ( Env
5 , Dict
6 , initialize
7 , get, freshDataScheme, ctorNames
8 , addValues
9 , instantiateFlex
10 , instantiateRigid
11 )
12 where
14import qualified Control.Monad.State.Strict as State
15import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Set as Set
18import Data.Text (Text)
20import qualified AST.Helpers as Help
21import qualified AST.Type as T
22import qualified AST.Variable as Var
23import qualified AST.Module as Module
24import Type.Type
28-- ENVIRONMENT
31data Env =
32 Env
33 { _ctor :: Dict Instantiator
34 , _value :: Dict Type
35 }
38type Instantiator =
39 IO (Int, [Variable], [Type], Type)
42type Dict a =
43 Map.Map Text a
46initialize :: [Module.CanonicalUnion] -> Env
47initialize unions =
48 Env (makeCtors unions) Map.empty
52-- CONSTRUCTORS
55makeCtors :: [Module.CanonicalUnion] -> Dict Instantiator
56makeCtors unions =
57 let
58 list t =
59 AppN Var.list [t]
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)
67 tupleCtor size =
68 let
69 name =
70 Help.makeTuple size
71 in
72 (name, inst size $ \vs -> (vs, AppN (Var.tuple size) vs))
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
85type VarDict =
86 Map.Map Text Variable
89makeCtorsHelp :: Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator
90makeCtorsHelp 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
101 tvars =
102 map T.Var rawTypeVars
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
114-- ACCESS TYPES
117{-# INLINE get #-}
118get :: Dict a -> Text -> a
119get dict var =
120 dict Map.! var
123freshDataScheme :: Env -> Text -> Instantiator
124freshDataScheme env var =
125 get (_ctor env) var
128ctorNames :: Env -> [Text]
129ctorNames env =
130 Map.keys (_ctor env)
134-- UPDATE ENVIRONMENT
137addValues :: VarDict -> Env -> Env
138addValues newValues env =
139 env { _value = Map.union (_value env) (Map.map VarN newValues) }
143-- INSTANTIATE TYPES
146instantiateFlex :: Env -> T.Canonical -> IO (Type, VarDict)
147instantiateFlex env sourceType =
148 State.runStateT (instantiator nameToFlex (_value env) sourceType) Map.empty
151instantiateRigid :: Env -> T.Canonical -> IO (Type, VarDict)
152instantiateRigid env sourceType =
153 State.runStateT (instantiator nameToRigid (_value env) sourceType) Map.empty
156instantiator :: (Text -> IO Variable) -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type
157instantiator nameToVar values sourceType =
158 instantiatorHelp nameToVar values Set.empty sourceType
161instantiatorHelp :: (Text -> IO Variable) -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
162instantiatorHelp 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
172 T.Var name ->
173 if Set.member name aliasVars then
174 return (PlaceHolder name)
176 else
177 case Map.lookup name values of
178 Just tipe ->
179 return tipe
181 Nothing ->
182 do dict <- State.get
183 case Map.lookup name dict of
184 Just variable ->
185 return (VarN variable)
187 Nothing ->
188 do variable <- State.liftIO (nameToVar name)
189 State.put (Map.insert name variable dict)
190 return (VarN variable)
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
199 T.Holey tipe ->
200 instantiatorHelp nameToVar values (Set.fromList (map fst args)) tipe
202 return (AliasN name targs realType)
204 T.Type name args ->
205 AppN name <$> traverse go args
207 T.Record fields ext ->
208 do tfields <- traverse go (Map.fromList fields)
209 text <-
210 case ext of
211 Nothing ->
212 return EmptyRecordN
214 Just extType ->
215 go extType
217 return $ RecordN tfields text