git.iko.soy/elk
on 21ccfbc help sign in
elk/src/Type/Environment.hs
235 lines 7.6 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 aliasType ->
190 do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
191 aliasedType' <-
192 case aliasType of
193 T.Filled tipe ->
194 instantiatorHelp env Set.empty tipe
195 T.Holey tipe ->
196 instantiatorHelp env (Set.fromList (map fst args)) tipe
198 case aliasedType' of
199 PlaceHolder _ ->
200 error "problem instantiating type"
202 VarN maybeSubAlias v ->
203 case maybeSubAlias of
204 Nothing ->
205 return (VarN (Just (name,args')) v)
206 Just _subAlias ->
207 return (TermN (Just (name,args')) (Var1 aliasedType'))
209 TermN maybeSubAlias t ->
210 case maybeSubAlias of
211 Nothing ->
212 return (TermN (Just (name, args')) t)
213 Just _subAlias ->
214 return (TermN (Just (name,args')) (Var1 aliasedType'))
216 T.Type name ->
217 case Map.lookup (V.toString name) (types env) of
218 Just t -> return t
219 Nothing ->
220 error $
221 "Could not find type constructor '" ++
222 V.toString name ++ "' while checking types."
224 T.App t ts ->
225 do t' <- go t
226 ts' <- mapM go ts
227 return $ foldl (<|) t' ts'
229 T.Record fields ext ->
230 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
231 ext' <-
232 case ext of
233 Nothing -> return $ termN EmptyRecord1
234 Just x -> go x
235 return $ termN (Record1 fields' ext')