git.iko.soy/elk
on 8aec074 help sign in
elk/src/Type/Environment.hs
226 lines 7.2 kB history raw
1module Type.Environment where
3import Control.Monad (forM)
4import qualified Control.Monad.State as State
5import qualified Data.Traversable as Traverse
6import qualified Data.Map as Map
7import qualified Data.Set as Set
8import Data.List (isPrefixOf)
10import qualified AST.Type as T
11import qualified AST.Variable as V
12import qualified AST.Module as Module
13import Type.Type
16type TypeDict = Map.Map String Type
17type VarDict = Map.Map String Variable
20data Environment = Environment
21 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
22 , types :: TypeDict
23 , value :: TypeDict
24 }
27initialEnvironment :: [Module.CanonicalAdt] -> IO Environment
28initialEnvironment datatypes =
29 do types <- makeTypes datatypes
30 let env =
31 Environment
32 { constructor = Map.empty
33 , value = Map.empty
34 , types = types
35 }
36 return $ env { constructor = makeConstructors env datatypes }
39makeTypes :: [Module.CanonicalAdt] -> IO TypeDict
40makeTypes datatypes =
41 do adts <- mapM makeImported datatypes
42 bs <- mapM makeBuiltin builtins
43 return (Map.fromList (adts ++ bs))
44 where
45 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)
46 makeImported (var, _) =
47 do tvar <- namedVar Constant var
48 return (V.toString var, varN tvar)
50 makeBuiltin :: (String, Int) -> IO (String, Type)
51 makeBuiltin (name, _) =
52 do name' <- namedVar Constant (V.builtin name)
53 return (name, varN name')
55 builtins :: [(String, Int)]
56 builtins =
57 concat
58 [ map tuple [0..9]
59 , kind 1 ["List"]
60 , kind 0 ["Int","Float","Char","String","Bool"]
61 ]
62 where
63 tuple n = ("_Tuple" ++ show n, n)
64 kind n names = map (\name -> (name, n)) names
67makeConstructors
68 :: Environment
69 -> [Module.CanonicalAdt]
70 -> Map.Map String (IO (Int, [Variable], [Type], Type))
71makeConstructors env datatypes =
72 Map.fromList builtins
73 where
74 list t =
75 (types env Map.! "List") <| t
77 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
78 inst numTVars tipe =
79 do vars <- forM [1..numTVars] $ \_ -> variable Flexible
80 let (args, result) = tipe (map (varN) vars)
81 return (length args, vars, args, result)
83 tupleCtor n =
84 let name = "_Tuple" ++ show n
85 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
87 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
88 builtins =
89 [ ("[]", inst 1 $ \ [t] -> ([], list t))
90 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
91 ] ++ map tupleCtor [0..9]
92 ++ concatMap (ctorToType env) datatypes
95ctorToType
96 :: Environment
97 -> (V.Canonical, Module.AdtInfo V.Canonical)
98 -> [(String, IO (Int, [Variable], [Type], Type))]
99ctorToType env (name, (tvars, ctors)) =
100 zip (map (V.toString . fst) ctors) (map inst ctors)
101 where
102 inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
103 inst ctor =
104 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
105 return (length args, Map.elems dict, args, tipe)
108 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
109 go (_, args) =
110 do types <- mapM (instantiator env) args
111 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
112 return (types, returnType)
115get :: Environment -> (Environment -> Map.Map String a) -> String -> a
116get env subDict key =
117 Map.findWithDefault (error msg) key (subDict env)
118 where
119 msg = "Could not find type constructor `" ++ key ++ "` while checking types."
122freshDataScheme
123 :: Environment
124 -> String
125 -> IO (Int, [Variable], [Type], Type)
126freshDataScheme env name =
127 get env constructor name
130instantiateType
131 :: Environment
132 -> T.Canonical
133 -> VarDict
134 -> IO ([Variable], Type)
135instantiateType env sourceType dict =
136 do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
137 return (Map.elems dict', tipe)
140instantiator
141 :: Environment
142 -> T.Canonical
143 -> State.StateT VarDict IO Type
144instantiator env sourceType =
145 instantiatorHelp env Set.empty sourceType
148instantiatorHelp
149 :: Environment
150 -> Set.Set String
151 -> T.Canonical
152 -> State.StateT VarDict IO Type
153instantiatorHelp env aliasVars sourceType =
154 let go = instantiatorHelp env aliasVars
155 in
156 case sourceType of
157 T.Lambda t1 t2 ->
158 (==>) <$> go t1 <*> go t2
160 T.Var x ->
161 do dict <- State.get
162 case Set.member x aliasVars of
163 True ->
164 return (PlaceHolder x)
165 False ->
166 case Map.lookup x dict of
167 Just v ->
168 return (varN v)
170 Nothing ->
171 do v <- State.liftIO $ namedVar flex (V.local x)
172 State.put (Map.insert x v dict)
173 return (varN v)
174 where
175 flex | "number" `isPrefixOf` x = Is Number
176 | "comparable" `isPrefixOf` x = Is Comparable
177 | "appendable" `isPrefixOf` x = Is Appendable
178 | otherwise = Flexible
180 T.Aliased name args aliasType ->
181 do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
182 aliasedType' <-
183 case aliasType of
184 T.Filled tipe ->
185 instantiatorHelp env Set.empty tipe
186 T.Holey tipe ->
187 instantiatorHelp env (Set.fromList (map fst args)) tipe
189 case aliasedType' of
190 PlaceHolder _ ->
191 error "problem instantiating type"
193 VarN maybeSubAlias v ->
194 case maybeSubAlias of
195 Nothing ->
196 return (VarN (Just (name,args')) v)
197 Just _subAlias ->
198 return (TermN (Just (name,args')) (Var1 aliasedType'))
200 TermN maybeSubAlias t ->
201 case maybeSubAlias of
202 Nothing ->
203 return (TermN (Just (name, args')) t)
204 Just _subAlias ->
205 return (TermN (Just (name,args')) (Var1 aliasedType'))
207 T.Type name ->
208 case Map.lookup (V.toString name) (types env) of
209 Just t -> return t
210 Nothing ->
211 error $
212 "Could not find type constructor `" ++
213 V.toString name ++ "` while checking types."
215 T.App t ts ->
216 do t' <- go t
217 ts' <- mapM go ts
218 return $ foldl (<|) t' ts'
220 T.Record fields ext ->
221 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
222 ext' <-
223 case ext of
224 Nothing -> return $ termN EmptyRecord1
225 Just x -> go x
226 return $ termN (Record1 fields' ext')