git.iko.soy/elk
on ef280ed help sign in
elk/src/Type/Environment.hs
237 lines 6.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Environment
3 ( Environment
4 , initialize
5 , getType, freshDataScheme, ctorNames
6 , addValues
7 , instantiateType
8 )
9 where
11import qualified Control.Monad.State as State
12import qualified Data.List as List
13import Data.Map ((!))
14import qualified Data.Map as Map
15import qualified Data.Set as Set
17import qualified AST.Type as T
18import qualified AST.Variable as V
19import qualified AST.Module as Module
20import Type.Type
23type TypeDict = Map.Map String Type
24type VarDict = Map.Map String Variable
27data Environment = Environment
28 { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
29 , _types :: TypeDict
30 , _value :: TypeDict
31 }
34initialize :: [Module.CanonicalAdt] -> IO Environment
35initialize datatypes =
36 do types <- makeTypes datatypes
37 let env =
38 Environment
39 { _constructor = Map.empty
40 , _value = Map.empty
41 , _types = types
42 }
43 return $ env { _constructor = makeConstructors env datatypes }
46makeTypes :: [Module.CanonicalAdt] -> IO TypeDict
47makeTypes datatypes =
48 do adts <- mapM makeImported datatypes
49 bs <- mapM makeBuiltin builtins
50 return (Map.fromList (adts ++ bs))
51 where
52 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)
53 makeImported (name, _) =
54 do tvar <- mkAtom name
55 return (V.toString name, VarN tvar)
57 makeBuiltin :: (String, Int) -> IO (String, Type)
58 makeBuiltin (name, _) =
59 do name' <- mkAtom (V.builtin name)
60 return (name, VarN name')
62 builtins :: [(String, Int)]
63 builtins =
64 concat
65 [ map tuple [0..9]
66 , kind 1 ["List"]
67 , kind 0 ["Int","Float","Char","String","Bool"]
68 ]
69 where
70 tuple n = ("_Tuple" ++ show n, n)
71 kind n names = map (\name -> (name, n)) names
74makeConstructors
75 :: Environment
76 -> [Module.CanonicalAdt]
77 -> Map.Map String (IO (Int, [Variable], [Type], Type))
78makeConstructors env datatypes =
79 Map.fromList builtins
80 where
81 list t =
82 (_types env ! "List") <| t
84 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
85 inst numTVars tipe =
86 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]
87 let (args, result) = tipe (map (VarN) vars)
88 return (length args, vars, args, result)
90 tupleCtor n =
91 let name = "_Tuple" ++ show n
92 in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))
94 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
95 builtins =
96 [ ("[]", inst 1 $ \ [t] -> ([], list t))
97 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
98 ] ++ map tupleCtor [0..9]
99 ++ concatMap (ctorToType env) datatypes
102ctorToType
103 :: Environment
104 -> (V.Canonical, Module.AdtInfo V.Canonical)
105 -> [(String, IO (Int, [Variable], [Type], Type))]
106ctorToType env (name, (tvars, ctors)) =
107 zip (map (V.toString . fst) ctors) (map inst ctors)
108 where
109 inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
110 inst ctor =
111 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
112 return (length args, Map.elems dict, args, tipe)
115 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
116 go (_, args) =
117 do types <- mapM (instantiator env) args
118 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
119 return (types, returnType)
123-- ACCESS TYPES
126get :: (Environment -> Map.Map String a) -> Environment -> String -> a
127get subDict env key =
128 Map.findWithDefault (error msg) key (subDict env)
129 where
130 msg = "Could not find type constructor `" ++ key ++ "` while checking types."
133getType :: Environment -> String -> Type
134getType =
135 get _types
138freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
139freshDataScheme =
140 get _constructor
143ctorNames :: Environment -> [String]
144ctorNames env =
145 Map.keys (_constructor env)
148-- UPDATE ENVIRONMENT
151addValues :: Environment -> [(String, Variable)] -> Environment
152addValues env newValues =
153 env
154 { _value =
155 List.foldl'
156 (\dict (name, var) -> Map.insert name (VarN var) dict)
157 (_value env)
158 newValues
159 }
163-- INSTANTIATE TYPES
166instantiateType :: Environment -> T.Canonical -> VarDict -> IO ([Variable], Type)
167instantiateType env sourceType dict =
168 do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
169 return (Map.elems dict', tipe)
172instantiator :: Environment -> T.Canonical -> State.StateT VarDict IO Type
173instantiator env sourceType =
174 instantiatorHelp env Set.empty sourceType
177instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
178instantiatorHelp env aliasVars sourceType =
179 let go = instantiatorHelp env aliasVars
180 in
181 case sourceType of
182 T.Lambda t1 t2 ->
183 (==>) <$> go t1 <*> go t2
185 T.Var name ->
186 if Set.member name aliasVars then
187 return (PlaceHolder name)
189 else
190 do dict <- State.get
191 case Map.lookup name dict of
192 Just variable ->
193 return (VarN variable)
195 Nothing ->
196 do variable <- State.liftIO (mkNamedVar name)
197 State.put (Map.insert name variable dict)
198 return (VarN variable)
200 T.Aliased name args aliasType ->
201 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
202 realType <-
203 case aliasType of
204 T.Filled tipe ->
205 instantiatorHelp env Set.empty tipe
207 T.Holey tipe ->
208 instantiatorHelp env (Set.fromList (map fst args)) tipe
210 return (AliasN name targs realType)
212 T.Type name ->
213 case Map.lookup (V.toString name) (_types env) of
214 Just tipe ->
215 return tipe
217 Nothing ->
218 error $
219 "Could not find type constructor `" ++
220 V.toString name ++ "` while checking types."
222 T.App func args ->
223 do tfunc <- go func
224 targs <- mapM go args
225 return $ foldl (<|) tfunc targs
227 T.Record fields ext ->
228 do tfields <- traverse go (Map.fromList fields)
229 text <-
230 case ext of
231 Nothing ->
232 return $ TermN EmptyRecord1
234 Just extType ->
235 go extType
237 return $ TermN (Record1 tfields text)