git.iko.soy/elk
on 445ea07 help sign in
elk/src/Type/Environment.hs
210 lines 5.1 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 , instantiateType
10 )
11 where
13import qualified Control.Monad.State.Strict as State
14import qualified Data.List as List
15import qualified Data.Map as Map
16import qualified Data.Set as Set
17import Data.Text (Text)
19import qualified AST.Helpers as Help
20import qualified AST.Type as T
21import qualified AST.Variable as Var
22import qualified AST.Module as Module
23import Type.Type
27-- ENVIRONMENT
30data Env =
31 Env
32 { _ctor :: Dict Instantiator
33 , _value :: Dict Type
34 }
37type Instantiator =
38 IO (Int, [Variable], [Type], Type)
41type Dict a =
42 Map.Map Text a
45initialize :: [Module.CanonicalUnion] -> Env
46initialize unions =
47 Env (makeCtors unions) Map.empty
51-- CONSTRUCTORS
54makeCtors :: [Module.CanonicalUnion] -> Dict Instantiator
55makeCtors unions =
56 let
57 list t =
58 AppN Var.list [t]
60 inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator
61 inst numTVars tipe =
62 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]
63 let (args, result) = tipe (map (VarN) vars)
64 return (length args, vars, args, result)
66 tupleCtor size =
67 let
68 name =
69 Help.makeTuple size
70 in
71 (name, inst size $ \vs -> (vs, AppN (Var.tuple size) vs))
73 builtins :: Dict Instantiator
74 builtins =
75 Map.fromList $
76 [ ("[]", inst 1 $ \ [t] -> ([], list t))
77 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
78 ]
79 ++ map tupleCtor [0..9]
80 in
81 List.foldl' makeCtorsHelp builtins unions
84type VarDict =
85 Map.Map Text Variable
88makeCtorsHelp :: Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator
89makeCtorsHelp constructorDict ( var, (rawTypeVars, ctors) ) =
90 let
91 inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator
92 inst ctorDict (name, rawArgs) =
93 Map.insert
94 (Var.toText name)
95 ( do ((args, tipe), dict) <- State.runStateT (go rawArgs) Map.empty
96 return ( length args, Map.elems dict, args, tipe )
97 )
98 ctorDict
100 tvars =
101 map T.Var rawTypeVars
103 go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)
104 go args =
105 do types <- mapM (instantiator Flex Map.empty) args
106 returnType <- instantiator Flex Map.empty (T.Type var tvars)
107 return (types, returnType)
108 in
109 List.foldl' inst constructorDict ctors
113-- ACCESS TYPES
116{-# INLINE get #-}
117get :: Dict a -> Text -> a
118get dict var =
119 dict Map.! var
122freshDataScheme :: Env -> Text -> Instantiator
123freshDataScheme env var =
124 get (_ctor env) var
127ctorNames :: Env -> [Text]
128ctorNames env =
129 Map.keys (_ctor env)
133-- UPDATE ENVIRONMENT
136addValues :: VarDict -> Env -> Env
137addValues newValues env =
138 env { _value = Map.union (_value env) (Map.map VarN newValues) }
142-- INSTANTIATE TYPES
145instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)
146instantiateType flex env sourceType =
147 State.runStateT (instantiator flex (_value env) sourceType) Map.empty
150instantiator :: Flex -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type
151instantiator flex values sourceType =
152 instantiatorHelp flex values Set.empty sourceType
155instantiatorHelp :: Flex -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
156instantiatorHelp flex values aliasVars sourceType =
157 let
158 go =
159 instantiatorHelp flex values aliasVars
160 in
161 case sourceType of
162 T.Lambda t1 t2 ->
163 (==>) <$> go t1 <*> go t2
165 T.Var name ->
166 if Set.member name aliasVars then
167 return (PlaceHolder name)
169 else
170 case Map.lookup name values of
171 Just tipe ->
172 return tipe
174 Nothing ->
175 do dict <- State.get
176 case Map.lookup name dict of
177 Just variable ->
178 return (VarN variable)
180 Nothing ->
181 do variable <- State.liftIO (mkNamedVar flex name)
182 State.put (Map.insert name variable dict)
183 return (VarN variable)
185 T.Aliased name args aliasType ->
186 do targs <- traverse (traverse go) args
187 realType <-
188 case aliasType of
189 T.Filled tipe ->
190 instantiatorHelp flex values Set.empty tipe
192 T.Holey tipe ->
193 instantiatorHelp flex values (Set.fromList (map fst args)) tipe
195 return (AliasN name targs realType)
197 T.Type name args ->
198 AppN name <$> traverse go args
200 T.Record fields ext ->
201 do tfields <- traverse go (Map.fromList fields)
202 text <-
203 case ext of
204 Nothing ->
205 return EmptyRecordN
207 Just extType ->
208 go extType
210 return $ RecordN tfields text