git.iko.soy/elk
on ebda137 help sign in
elk/src/Type/Environment.hs
221 lines 7.0 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 x ->
194 return (PlaceHolder x)
196 VarN _ v ->
197 return (VarN (Just (name,args')) v)
199 TermN _ t ->
200 return (TermN (Just (name, args')) t)
202 T.Type name ->
203 case Map.lookup (V.toString name) (types env) of
204 Just t -> return t
205 Nothing ->
206 error $
207 "Could not find type constructor '" ++
208 V.toString name ++ "' while checking types."
210 T.App t ts ->
211 do t' <- go t
212 ts' <- mapM go ts
213 return $ foldl (<|) t' ts'
215 T.Record fields ext ->
216 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
217 ext' <-
218 case ext of
219 Nothing -> return $ termN EmptyRecord1
220 Just x -> go x
221 return $ termN (Record1 fields' ext')