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