git.iko.soy/elk
on 684504e help sign in
elk/src/Type/Environment.hs
239 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.CanonicalUnion] -> 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.CanonicalUnion] -> IO TypeDict
47makeTypes datatypes =
48 do unions <- mapM makeImported datatypes
49 bs <- mapM makeBuiltin builtins
50 return (Map.fromList (unions ++ bs))
51 where
52 makeImported :: (V.Canonical, Module.UnionInfo 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.CanonicalUnion]
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.UnionInfo 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
180 go =
181 instantiatorHelp env aliasVars
182 in
183 case sourceType of
184 T.Lambda t1 t2 ->
185 (==>) <$> go t1 <*> go t2
187 T.Var name ->
188 if Set.member name aliasVars then
189 return (PlaceHolder name)
191 else
192 do dict <- State.get
193 case Map.lookup name dict of
194 Just variable ->
195 return (VarN variable)
197 Nothing ->
198 do variable <- State.liftIO (mkNamedVar name)
199 State.put (Map.insert name variable dict)
200 return (VarN variable)
202 T.Aliased name args aliasType ->
203 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
204 realType <-
205 case aliasType of
206 T.Filled tipe ->
207 instantiatorHelp env Set.empty tipe
209 T.Holey tipe ->
210 instantiatorHelp env (Set.fromList (map fst args)) tipe
212 return (AliasN name targs realType)
214 T.Type name ->
215 case Map.lookup (V.toString name) (_types env) of
216 Just tipe ->
217 return tipe
219 Nothing ->
220 error $
221 "Could not find type constructor `" ++
222 V.toString name ++ "` while checking types."
224 T.App func args ->
225 do tfunc <- go func
226 targs <- mapM go args
227 return $ foldl (<|) tfunc targs
229 T.Record fields ext ->
230 do tfields <- traverse go (Map.fromList fields)
231 text <-
232 case ext of
233 Nothing ->
234 return $ TermN EmptyRecord1
236 Just extType ->
237 go extType
239 return $ TermN (Record1 tfields text)