git.iko.soy/elk
on dfdf96d help sign in
elk/compiler/Type/Environment.hs
168 lines 6.1 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Environment where
4import Control.Applicative ((<$>), (<*>))
5import Control.Exception (try, SomeException)
6import Control.Monad
7import Control.Monad.Trans.Error (ErrorList(..))
8import Control.Monad.Error (ErrorT, throwError, liftIO)
9import qualified Control.Monad.State as State
10import qualified Data.Traversable as Traverse
11import qualified Data.Map as Map
12import Data.List (isPrefixOf)
13import qualified Text.PrettyPrint as PP
15import qualified AST.Type as T
16import qualified AST.Variable as V
17import AST.Module (CanonicalAdt, AdtInfo)
18import Type.Type
20type TypeDict = Map.Map String Type
21type 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 }
29initialEnvironment :: [CanonicalAdt] -> IO Environment
30initialEnvironment datatypes = do
31 types <- makeTypes datatypes
32 let env = Environment
33 { constructor = Map.empty
34 , value = Map.empty
35 , types = types
36 }
37 return $ env { constructor = makeConstructors env datatypes }
39makeTypes :: [CanonicalAdt] -> IO TypeDict
40makeTypes datatypes =
41 do adts <- mapM makeImported datatypes
42 bs <- mapM makeBuiltin builtins
43 return (Map.fromList (adts ++ bs))
44 where
45 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
46 makeImported (var, _) = do
47 tvar <- namedVar Constant var
48 return (V.toString var, VarN tvar)
50 makeBuiltin :: (String, Int) -> IO (String, Type)
51 makeBuiltin (name, _) = do
52 name' <- namedVar Constant (V.builtin name)
53 return (name, VarN name')
55 builtins :: [(String, Int)]
56 builtins = concat [ map tuple [0..9]
57 , kind 1 ["_List"]
58 , kind 0 ["Int","Float","Char","String","Bool"]
59 ]
60 where
61 tuple n = ("_Tuple" ++ show n, n)
62 kind n names = map (\name -> (name, n)) names
66makeConstructors :: Environment
67 -> [CanonicalAdt]
68 -> Map.Map String (IO (Int, [Variable], [Type], Type))
69makeConstructors env datatypes = Map.fromList builtins
70 where
71 list t = (types env Map.! "_List") <| t
73 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
74 inst numTVars tipe = do
75 vars <- forM [1..numTVars] $ \_ -> var Flexible
76 let (args, result) = tipe (map VarN vars)
77 return (length args, vars, args, result)
79 tupleCtor n =
80 let name = "_Tuple" ++ show n
81 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
83 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
84 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
85 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
86 ] ++ map tupleCtor [0..9]
87 ++ concatMap (ctorToType env) datatypes
90ctorToType :: Environment
91 -> (V.Canonical, AdtInfo V.Canonical)
92 -> [(String, IO (Int, [Variable], [Type], Type))]
93ctorToType env (name, (tvars, ctors)) =
94 zip (map (V.toString . fst) ctors) (map inst ctors)
95 where
96 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
97 inst ctor = do
98 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
99 return (length args, Map.elems dict, args, tipe)
102 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
103 go (_, args) = do
104 types <- mapM (instantiator env) args
105 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
106 return (types, returnType)
109get :: Environment -> (Environment -> Map.Map String a) -> String -> a
110get env subDict key = Map.findWithDefault err key (subDict env)
111 where
112 err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
115freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
116freshDataScheme env name = get env constructor name
118instance ErrorList PP.Doc where
119 listMsg str = [PP.text str]
121instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
122instantiateType env sourceType dict =
123 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
124 case result :: Either SomeException (Type, VarDict) of
125 Left someError -> throwError [ PP.text $ show someError ]
126 Right (tipe, dict') -> return (Map.elems dict', tipe)
128instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
129instantiator env sourceType = go sourceType
130 where
131 go :: T.CanonicalType -> State.StateT VarDict IO Type
132 go sourceType =
133 case sourceType of
134 T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
136 T.Var x -> do
137 dict <- State.get
138 case Map.lookup x dict of
139 Just v -> return (VarN v)
140 Nothing ->
141 do var <- State.liftIO $ namedVar flex (V.local x)
142 State.put (Map.insert x var dict)
143 return (VarN var)
144 where
145 flex | "number" `isPrefixOf` x = Is Number
146 | "comparable" `isPrefixOf` x = Is Comparable
147 | "appendable" `isPrefixOf` x = Is Appendable
148 | otherwise = Flexible
150 T.Aliased _ t -> go t
152 T.Type var ->
153 case Map.lookup (V.toString var) (types env) of
154 Just t -> return t
155 Nothing -> error $ "Could not find type constructor '" ++
156 V.toString var ++ "' while checking types."
158 T.App t ts -> do
159 t' <- go t
160 ts' <- mapM go ts
161 return $ foldl (<|) t' ts'
163 T.Record fields ext -> do
164 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
165 ext' <- case ext of
166 Nothing -> return $ TermN EmptyRecord1
167 Just x -> go x
168 return $ TermN (Record1 fields' ext')