git.iko.soy/elk
on 552becc help sign in
elk/src/Type/Environment.hs
229 lines 7.4 kB history raw
1module Type.Environment where
3import Control.Applicative ((<$>), (<*>))
4import Control.Exception (try, SomeException)
5import Control.Monad
6import Control.Monad.Error (ErrorT, throwError, liftIO)
7import qualified Control.Monad.State as State
8import qualified Data.Traversable as Traverse
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Data.List (isPrefixOf)
12import qualified Text.PrettyPrint as PP
14import qualified AST.Type as T
15import qualified AST.Variable as V
16import AST.Module (CanonicalAdt, AdtInfo)
17import Type.Type
20type TypeDict = Map.Map String Type
21type VarDict = Map.Map String Variable
24data Environment = Environment
25 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
26 , types :: TypeDict
27 , value :: TypeDict
28 }
31initialEnvironment :: [CanonicalAdt] -> IO Environment
32initialEnvironment datatypes =
33 do types <- makeTypes datatypes
34 let env =
35 Environment
36 { constructor = Map.empty
37 , value = Map.empty
38 , types = types
39 }
40 return $ env { constructor = makeConstructors env datatypes }
43makeTypes :: [CanonicalAdt] -> IO TypeDict
44makeTypes datatypes =
45 do adts <- mapM makeImported datatypes
46 bs <- mapM makeBuiltin builtins
47 return (Map.fromList (adts ++ bs))
48 where
49 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
50 makeImported (var, _) =
51 do tvar <- namedVar Constant var
52 return (V.toString var, varN tvar)
54 makeBuiltin :: (String, Int) -> IO (String, Type)
55 makeBuiltin (name, _) =
56 do name' <- namedVar Constant (V.builtin name)
57 return (name, varN name')
59 builtins :: [(String, Int)]
60 builtins =
61 concat
62 [ map tuple [0..9]
63 , kind 1 ["List"]
64 , kind 0 ["Int","Float","Char","String","Bool"]
65 ]
66 where
67 tuple n = ("_Tuple" ++ show n, n)
68 kind n names = map (\name -> (name, n)) names
71makeConstructors
72 :: Environment
73 -> [CanonicalAdt]
74 -> Map.Map String (IO (Int, [Variable], [Type], Type))
75makeConstructors env datatypes =
76 Map.fromList builtins
77 where
78 list t =
79 (types env Map.! "List") <| t
81 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
82 inst numTVars tipe =
83 do vars <- forM [1..numTVars] $ \_ -> variable Flexible
84 let (args, result) = tipe (map (varN) vars)
85 return (length args, vars, args, result)
87 tupleCtor n =
88 let name = "_Tuple" ++ show n
89 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
91 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
92 builtins =
93 [ ("[]", inst 1 $ \ [t] -> ([], list t))
94 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
95 ] ++ map tupleCtor [0..9]
96 ++ concatMap (ctorToType env) datatypes
99ctorToType
100 :: Environment
101 -> (V.Canonical, AdtInfo V.Canonical)
102 -> [(String, IO (Int, [Variable], [Type], Type))]
103ctorToType env (name, (tvars, ctors)) =
104 zip (map (V.toString . fst) ctors) (map inst ctors)
105 where
106 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
107 inst ctor =
108 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
109 return (length args, Map.elems dict, args, tipe)
112 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
113 go (_, args) =
114 do types <- mapM (instantiator env) args
115 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
116 return (types, returnType)
119get :: Environment -> (Environment -> Map.Map String a) -> String -> a
120get env subDict key =
121 Map.findWithDefault (error msg) key (subDict env)
122 where
123 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
126freshDataScheme
127 :: Environment
128 -> String
129 -> IO (Int, [Variable], [Type], Type)
130freshDataScheme env name =
131 get env constructor name
134instantiateType
135 :: Environment
136 -> T.CanonicalType
137 -> VarDict
138 -> ErrorT [PP.Doc] IO ([Variable], Type)
139instantiateType env sourceType dict =
140 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
141 case result :: Either SomeException (Type, VarDict) of
142 Left someError ->
143 throwError [ PP.text $ show someError ]
145 Right (tipe, dict') ->
146 return (Map.elems dict', tipe)
149instantiator
150 :: Environment
151 -> T.CanonicalType
152 -> State.StateT VarDict IO Type
153instantiator env sourceType =
154 instantiatorHelp env Set.empty sourceType
157instantiatorHelp
158 :: Environment
159 -> Set.Set String
160 -> T.CanonicalType
161 -> State.StateT VarDict IO Type
162instantiatorHelp env aliasVars sourceType =
163 let go = instantiatorHelp env aliasVars
164 in
165 case sourceType of
166 T.Lambda t1 t2 ->
167 (==>) <$> go t1 <*> go t2
169 T.Var x ->
170 do dict <- State.get
171 case Set.member x aliasVars of
172 True ->
173 return (PlaceHolder x)
174 False ->
175 case Map.lookup x dict of
176 Just v ->
177 return (varN v)
179 Nothing ->
180 do v <- State.liftIO $ namedVar flex (V.local x)
181 State.put (Map.insert x v dict)
182 return (varN v)
183 where
184 flex | "number" `isPrefixOf` x = Is Number
185 | "comparable" `isPrefixOf` x = Is Comparable
186 | "appendable" `isPrefixOf` x = Is Appendable
187 | otherwise = Flexible
189 T.Aliased name args aliasedType ->
190 do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
191 aliasedType' <- instantiatorHelp env (Set.fromList (map fst args)) aliasedType
192 case aliasedType' of
193 PlaceHolder _ ->
194 error "problem instantiating type"
196 VarN maybeSubAlias v ->
197 case maybeSubAlias of
198 Nothing ->
199 return (VarN (Just (name,args')) v)
200 Just _subAlias ->
201 return (TermN (Just (name,args')) (Var1 aliasedType'))
203 TermN maybeSubAlias t ->
204 case maybeSubAlias of
205 Nothing ->
206 return (TermN (Just (name, args')) t)
207 Just _subAlias ->
208 return (TermN (Just (name,args')) (Var1 aliasedType'))
210 T.Type name ->
211 case Map.lookup (V.toString name) (types env) of
212 Just t -> return t
213 Nothing ->
214 error $
215 "Could not find type constructor '" ++
216 V.toString name ++ "' while checking types."
218 T.App t ts ->
219 do t' <- go t
220 ts' <- mapM go ts
221 return $ foldl (<|) t' ts'
223 T.Record fields ext ->
224 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
225 ext' <-
226 case ext of
227 Nothing -> return $ termN EmptyRecord1
228 Just x -> go x
229 return $ termN (Record1 fields' ext')