git.iko.soy/elk
on aeb02cd help sign in
elk/src/Type/Environment.hs
200 lines 6.3 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 Data.List (isPrefixOf)
11import qualified Text.PrettyPrint as PP
13import qualified AST.Type as T
14import qualified AST.Variable as V
15import AST.Module (CanonicalAdt, AdtInfo)
16import Type.Type
19type TypeDict = Map.Map String Type
20type VarDict = Map.Map String Variable
23data Environment = Environment
24 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
25 , types :: TypeDict
26 , value :: TypeDict
27 }
30initialEnvironment :: [CanonicalAdt] -> IO Environment
31initialEnvironment datatypes =
32 do types <- makeTypes datatypes
33 let env =
34 Environment
35 { constructor = Map.empty
36 , value = Map.empty
37 , types = types
38 }
39 return $ env { constructor = makeConstructors env datatypes }
42makeTypes :: [CanonicalAdt] -> IO TypeDict
43makeTypes datatypes =
44 do adts <- mapM makeImported datatypes
45 bs <- mapM makeBuiltin builtins
46 return (Map.fromList (adts ++ bs))
47 where
48 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
49 makeImported (var, _) =
50 do tvar <- namedVar Constant var
51 return (V.toString var, varN tvar)
53 makeBuiltin :: (String, Int) -> IO (String, Type)
54 makeBuiltin (name, _) =
55 do name' <- namedVar Constant (V.builtin name)
56 return (name, varN name')
58 builtins :: [(String, Int)]
59 builtins =
60 concat
61 [ map tuple [0..9]
62 , kind 1 ["List"]
63 , kind 0 ["Int","Float","Char","String","Bool"]
64 ]
65 where
66 tuple n = ("_Tuple" ++ show n, n)
67 kind n names = map (\name -> (name, n)) names
70makeConstructors
71 :: Environment
72 -> [CanonicalAdt]
73 -> Map.Map String (IO (Int, [Variable], [Type], Type))
74makeConstructors env datatypes =
75 Map.fromList builtins
76 where
77 list t =
78 (types env Map.! "List") <| t
80 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
81 inst numTVars tipe =
82 do vars <- forM [1..numTVars] $ \_ -> variable Flexible
83 let (args, result) = tipe (map (varN) vars)
84 return (length args, vars, args, result)
86 tupleCtor n =
87 let name = "_Tuple" ++ show n
88 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
90 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
91 builtins =
92 [ ("[]", inst 1 $ \ [t] -> ([], list t))
93 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
94 ] ++ map tupleCtor [0..9]
95 ++ concatMap (ctorToType env) datatypes
98ctorToType
99 :: Environment
100 -> (V.Canonical, AdtInfo V.Canonical)
101 -> [(String, IO (Int, [Variable], [Type], Type))]
102ctorToType env (name, (tvars, ctors)) =
103 zip (map (V.toString . fst) ctors) (map inst ctors)
104 where
105 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
106 inst ctor =
107 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
108 return (length args, Map.elems dict, args, tipe)
111 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
112 go (_, args) =
113 do types <- mapM (instantiator env) args
114 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
115 return (types, returnType)
118get :: Environment -> (Environment -> Map.Map String a) -> String -> a
119get env subDict key =
120 Map.findWithDefault (error msg) key (subDict env)
121 where
122 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
125freshDataScheme
126 :: Environment
127 -> String
128 -> IO (Int, [Variable], [Type], Type)
129freshDataScheme env name =
130 get env constructor name
133instantiateType
134 :: Environment
135 -> T.CanonicalType
136 -> VarDict
137 -> ErrorT [PP.Doc] IO ([Variable], Type)
138instantiateType env sourceType dict =
139 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
140 case result :: Either SomeException (Type, VarDict) of
141 Left someError ->
142 throwError [ PP.text $ show someError ]
144 Right (tipe, dict') ->
145 return (Map.elems dict', tipe)
148instantiator
149 :: Environment
150 -> T.CanonicalType
151 -> State.StateT VarDict IO Type
152instantiator env sourceType =
153 go sourceType
154 where
155 go :: T.CanonicalType -> State.StateT VarDict IO Type
156 go sourceType =
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 Map.lookup x dict of
164 Just v -> return (varN v)
165 Nothing ->
166 do v <- State.liftIO $ namedVar flex (V.local x)
167 State.put (Map.insert x v dict)
168 return (varN v)
169 where
170 flex | "number" `isPrefixOf` x = Is Number
171 | "comparable" `isPrefixOf` x = Is Comparable
172 | "appendable" `isPrefixOf` x = Is Appendable
173 | otherwise = Flexible
175 T.Aliased name t ->
176 do t' <- go t
177 case t' of
178 VarN _ v -> return (VarN (Just name) v)
179 TermN _ term -> return (TermN (Just name) term)
181 T.Type name ->
182 case Map.lookup (V.toString name) (types env) of
183 Just t -> return t
184 Nothing ->
185 error $
186 "Could not find type constructor '" ++
187 V.toString name ++ "' while checking types."
189 T.App t ts ->
190 do t' <- go t
191 ts' <- mapM go ts
192 return $ foldl (<|) t' ts'
194 T.Record fields ext ->
195 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
196 ext' <-
197 case ext of
198 Nothing -> return $ termN EmptyRecord1
199 Just x -> go x
200 return $ termN (Record1 fields' ext')