git.iko.soy/elk
on eb97f2a help sign in
elk/src/Type/Environment.hs
237 lines 6.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Environment
3 ( Env
4 , initialize
5 , getType, freshDataScheme, ctorNames
6 , addValues
7 , instantiateType
8 )
9 where
11import qualified Control.Monad.State as State
12import Data.Map ((!))
13import qualified Data.Map as Map
14import qualified Data.Set as Set
16import qualified AST.Type as T
17import qualified AST.Variable as V
18import qualified AST.Module as Module
19import Type.Type
22type TypeDict = Map.Map String Type
23type VarDict = Map.Map String Variable
26data Env = Env
27 { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
28 , _types :: TypeDict
29 , _value :: TypeDict
30 }
33initialize :: [Module.CanonicalUnion] -> IO Env
34initialize datatypes =
35 do types <- makeTypes datatypes
36 let env =
37 Env
38 { _constructor = Map.empty
39 , _value = Map.empty
40 , _types = types
41 }
42 return $ env { _constructor = makeConstructors env datatypes }
45makeTypes :: [Module.CanonicalUnion] -> IO TypeDict
46makeTypes datatypes =
47 do unions <- mapM makeImported datatypes
48 bs <- mapM makeBuiltin builtins
49 return (Map.fromList (unions ++ bs))
50 where
51 makeImported :: (V.Canonical, Module.UnionInfo V.Canonical) -> IO (String, Type)
52 makeImported (name, _) =
53 do tvar <- mkAtom name
54 return (V.toString name, VarN tvar)
56 makeBuiltin :: (String, Int) -> IO (String, Type)
57 makeBuiltin (name, _) =
58 do name' <- mkAtom (V.builtin name)
59 return (name, VarN name')
61 builtins :: [(String, Int)]
62 builtins =
63 concat
64 [ map tuple [0..9]
65 , kind 1 ["List"]
66 , kind 0 ["Int","Float","Char","String","Bool"]
67 ]
68 where
69 tuple n = ("_Tuple" ++ show n, n)
70 kind n names = map (\name -> (name, n)) names
73makeConstructors
74 :: Env
75 -> [Module.CanonicalUnion]
76 -> Map.Map String (IO (Int, [Variable], [Type], Type))
77makeConstructors env datatypes =
78 Map.fromList builtins
79 where
80 list t =
81 (_types env ! "List") <| t
83 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
84 inst numTVars tipe =
85 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]
86 let (args, result) = tipe (map (VarN) vars)
87 return (length args, vars, args, result)
89 tupleCtor n =
90 let name = "_Tuple" ++ show n
91 in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))
93 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
94 builtins =
95 [ ("[]", inst 1 $ \ [t] -> ([], list t))
96 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
97 ] ++ map tupleCtor [0..9]
98 ++ concatMap (ctorToType env) datatypes
101ctorToType
102 :: Env
103 -> (V.Canonical, Module.UnionInfo V.Canonical)
104 -> [(String, IO (Int, [Variable], [Type], Type))]
105ctorToType env (name, (tvars, ctors)) =
106 zip (map (V.toString . fst) ctors) (map inst ctors)
107 where
108 inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
109 inst ctor =
110 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
111 return (length args, Map.elems dict, args, tipe)
114 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
115 go (_, args) =
116 do types <- mapM (instantiator Flex env) args
117 returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))
118 return (types, returnType)
122-- ACCESS TYPES
125get :: (Env -> Map.Map String a) -> Env -> String -> a
126get subDict env key =
127 Map.findWithDefault (error msg) key (subDict env)
128 where
129 msg = "Could not find type constructor `" ++ key ++ "` while checking types."
132getType :: Env -> String -> Type
133getType =
134 get _types
137freshDataScheme :: Env -> String -> IO (Int, [Variable], [Type], Type)
138freshDataScheme =
139 get _constructor
142ctorNames :: Env -> [String]
143ctorNames env =
144 Map.keys (_constructor env)
148-- UPDATE ENVIRONMENT
151addValues :: VarDict -> Env -> Env
152addValues newValues env =
153 env { _value = Map.union (_value env) (Map.map VarN newValues) }
157-- INSTANTIATE TYPES
160instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)
161instantiateType flex env sourceType =
162 State.runStateT (instantiator flex env sourceType) Map.empty
165instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type
166instantiator flex env sourceType =
167 instantiatorHelp flex env Set.empty sourceType
170instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
171instantiatorHelp flex env aliasVars sourceType =
172 let
173 go =
174 instantiatorHelp flex env aliasVars
175 in
176 case sourceType of
177 T.Lambda t1 t2 ->
178 (==>) <$> go t1 <*> go t2
180 T.Var name ->
181 if Set.member name aliasVars then
182 return (PlaceHolder name)
184 else
185 do dict <- State.get
186 case Map.lookup name (_value env) of
187 Just tipe ->
188 return tipe
190 Nothing ->
191 case Map.lookup name dict of
192 Just variable ->
193 return (VarN variable)
195 Nothing ->
196 do variable <- State.liftIO (mkNamedVar flex 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 flex env Set.empty tipe
207 T.Holey tipe ->
208 instantiatorHelp flex 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)