git.iko.soy/elk
on dbe27eb help sign in
elk/src/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.Error (ErrorT, throwError, liftIO)
8import qualified Control.Monad.State as State
9import qualified Data.Traversable as Traverse
10import qualified Data.Map as Map
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
19type TypeDict = Map.Map String Type
20type VarDict = Map.Map String Variable
22data Environment = Environment
23 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
24 , types :: TypeDict
25 , value :: TypeDict
26 }
28initialEnvironment :: [CanonicalAdt] -> IO Environment
29initialEnvironment datatypes = do
30 types <- makeTypes datatypes
31 let env = Environment
32 { constructor = Map.empty
33 , value = Map.empty
34 , types = types
35 }
36 return $ env { constructor = makeConstructors env datatypes }
38makeTypes :: [CanonicalAdt] -> IO TypeDict
39makeTypes datatypes =
40 do adts <- mapM makeImported datatypes
41 bs <- mapM makeBuiltin builtins
42 return (Map.fromList (adts ++ bs))
43 where
44 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
45 makeImported (var, _) = do
46 tvar <- namedVar Constant var
47 return (V.toString var, varN tvar)
49 makeBuiltin :: (String, Int) -> IO (String, Type)
50 makeBuiltin (name, _) = do
51 name' <- namedVar Constant (V.builtin name)
52 return (name, varN name')
54 builtins :: [(String, Int)]
55 builtins = concat [ map tuple [0..9]
56 , kind 1 ["_List"]
57 , kind 0 ["Int","Float","Char","String","Bool"]
58 ]
59 where
60 tuple n = ("_Tuple" ++ show n, n)
61 kind n names = map (\name -> (name, n)) names
65makeConstructors :: Environment
66 -> [CanonicalAdt]
67 -> Map.Map String (IO (Int, [Variable], [Type], Type))
68makeConstructors env datatypes = Map.fromList builtins
69 where
70 list t = (types env Map.! "_List") <| t
72 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
73 inst numTVars tipe = do
74 vars <- forM [1..numTVars] $ \_ -> variable Flexible
75 let (args, result) = tipe (map (varN) vars)
76 return (length args, vars, args, result)
78 tupleCtor n =
79 let name = "_Tuple" ++ show n
80 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
82 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
83 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
84 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
85 ] ++ map tupleCtor [0..9]
86 ++ concatMap (ctorToType env) datatypes
89ctorToType :: Environment
90 -> (V.Canonical, AdtInfo V.Canonical)
91 -> [(String, IO (Int, [Variable], [Type], Type))]
92ctorToType env (name, (tvars, ctors)) =
93 zip (map (V.toString . fst) ctors) (map inst ctors)
94 where
95 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
96 inst ctor = do
97 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
98 return (length args, Map.elems dict, args, tipe)
101 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
102 go (_, args) = do
103 types <- mapM (instantiator env) args
104 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
105 return (types, returnType)
108get :: Environment -> (Environment -> Map.Map String a) -> String -> a
109get env subDict key = Map.findWithDefault (error msg) key (subDict env)
110 where
111 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
115freshDataScheme env name = get env constructor name
117instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
118instantiateType env sourceType dict =
119 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
120 case result :: Either SomeException (Type, VarDict) of
121 Left someError -> throwError [ PP.text $ show someError ]
122 Right (tipe, dict') -> return (Map.elems dict', tipe)
124instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
125instantiator env sourceType = go sourceType
126 where
127 go :: T.CanonicalType -> State.StateT VarDict IO Type
128 go sourceType =
129 case sourceType of
130 T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
132 T.Var x -> do
133 dict <- State.get
134 case Map.lookup x dict of
135 Just v -> return (varN v)
136 Nothing ->
137 do v <- State.liftIO $ namedVar flex (V.local x)
138 State.put (Map.insert x v dict)
139 return (varN v)
140 where
141 flex | "number" `isPrefixOf` x = Is Number
142 | "comparable" `isPrefixOf` x = Is Comparable
143 | "appendable" `isPrefixOf` x = Is Appendable
144 | otherwise = Flexible
146 T.Aliased name t -> do
147 t' <- go t
148 case t' of
149 VarN _ v -> return (VarN (Just name) v)
150 TermN _ term -> return (TermN (Just name) term)
152 T.Type name ->
153 case Map.lookup (V.toString name) (types env) of
154 Just t -> return t
155 Nothing -> error $ "Could not find type constructor '" ++
156 V.toString name ++ "' 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')