git.iko.soy/elk
on 2ec798e help sign in
elk/src/Type/Environment.hs
167 lines 6.1 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
18type TypeDict = Map.Map String Type
19type 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 }
27initialEnvironment :: [CanonicalAdt] -> IO Environment
28initialEnvironment datatypes = do
29 types <- makeTypes datatypes
30 let env = Environment
31 { constructor = Map.empty
32 , value = Map.empty
33 , types = types
34 }
35 return $ env { constructor = makeConstructors env datatypes }
37makeTypes :: [CanonicalAdt] -> IO TypeDict
38makeTypes datatypes =
39 do adts <- mapM makeImported datatypes
40 bs <- mapM makeBuiltin builtins
41 return (Map.fromList (adts ++ bs))
42 where
43 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
44 makeImported (var, _) = do
45 tvar <- namedVar Constant var
46 return (V.toString var, varN tvar)
48 makeBuiltin :: (String, Int) -> IO (String, Type)
49 makeBuiltin (name, _) = do
50 name' <- namedVar Constant (V.builtin name)
51 return (name, varN name')
53 builtins :: [(String, Int)]
54 builtins = concat [ map tuple [0..9]
55 , kind 1 ["List"]
56 , kind 0 ["Int","Float","Char","String","Bool"]
57 ]
58 where
59 tuple n = ("_Tuple" ++ show n, n)
60 kind n names = map (\name -> (name, n)) names
64makeConstructors :: Environment
65 -> [CanonicalAdt]
66 -> Map.Map String (IO (Int, [Variable], [Type], Type))
67makeConstructors env datatypes = Map.fromList builtins
68 where
69 list t = (types env Map.! "List") <| t
71 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
72 inst numTVars tipe = do
73 vars <- forM [1..numTVars] $ \_ -> variable Flexible
74 let (args, result) = tipe (map (varN) vars)
75 return (length args, vars, args, result)
77 tupleCtor n =
78 let name = "_Tuple" ++ show n
79 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
81 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
82 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
83 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
84 ] ++ map tupleCtor [0..9]
85 ++ concatMap (ctorToType env) datatypes
88ctorToType :: Environment
89 -> (V.Canonical, AdtInfo V.Canonical)
90 -> [(String, IO (Int, [Variable], [Type], Type))]
91ctorToType env (name, (tvars, ctors)) =
92 zip (map (V.toString . fst) ctors) (map inst ctors)
93 where
94 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
95 inst ctor = do
96 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
97 return (length args, Map.elems dict, args, tipe)
100 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
101 go (_, args) = do
102 types <- mapM (instantiator env) args
103 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
104 return (types, returnType)
107get :: Environment -> (Environment -> Map.Map String a) -> String -> a
108get env subDict key = Map.findWithDefault (error msg) key (subDict env)
109 where
110 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
113freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
114freshDataScheme env name = get env constructor name
116instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
117instantiateType env sourceType dict =
118 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
119 case result :: Either SomeException (Type, VarDict) of
120 Left someError -> throwError [ PP.text $ show someError ]
121 Right (tipe, dict') -> return (Map.elems dict', tipe)
123instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
124instantiator env sourceType = go sourceType
125 where
126 go :: T.CanonicalType -> State.StateT VarDict IO Type
127 go sourceType =
128 case sourceType of
129 T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
131 T.Var x -> do
132 dict <- State.get
133 case Map.lookup x dict of
134 Just v -> return (varN v)
135 Nothing ->
136 do v <- State.liftIO $ namedVar flex (V.local x)
137 State.put (Map.insert x v dict)
138 return (varN v)
139 where
140 flex | "number" `isPrefixOf` x = Is Number
141 | "comparable" `isPrefixOf` x = Is Comparable
142 | "appendable" `isPrefixOf` x = Is Appendable
143 | otherwise = Flexible
145 T.Aliased name t -> do
146 t' <- go t
147 case t' of
148 VarN _ v -> return (VarN (Just name) v)
149 TermN _ term -> return (TermN (Just name) term)
151 T.Type name ->
152 case Map.lookup (V.toString name) (types env) of
153 Just t -> return t
154 Nothing -> error $ "Could not find type constructor '" ++
155 V.toString name ++ "' while checking types."
157 T.App t ts -> do
158 t' <- go t
159 ts' <- mapM go ts
160 return $ foldl (<|) t' ts'
162 T.Record fields ext -> do
163 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
164 ext' <- case ext of
165 Nothing -> return $ termN EmptyRecord1
166 Just x -> go x
167 return $ termN (Record1 fields' ext')