git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Type/Environment.hs
170 lines 6.6 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 SourceSyntax.Type as Src
16import SourceSyntax.Module (ADT, Alias)
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 aliases :: Map.Map String ([String], Src.Type),
25 types :: TypeDict,
26 value :: TypeDict
29initialEnvironment :: [ADT] -> [Alias] -> IO Environment
30initialEnvironment datatypes aliases = do
31 types <- makeTypes datatypes
32 let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases
33 env = Environment {
34 constructor = Map.empty,
35 value = Map.empty,
36 types = types,
37 aliases = aliases' }
39 return $ env { constructor = makeConstructors env datatypes }
41makeTypes :: [ADT] -> IO TypeDict
42makeTypes datatypes =
43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
44 where
45 nameAndKind (name, tvars, _, _) = (name, length tvars)
47 makeCtor (name, _) = do
48 ctor <- VarN <$> namedVar Constant name
49 return (name, ctor)
51 tuple n = ("_Tuple" ++ show n, n)
53 kind n names = map (\name -> (name, n)) names
55 builtins :: [(String,Int)]
56 builtins = concat [ map tuple [0..9]
57 , kind 1 ["_List"]
58 , kind 0 ["Int","Float","Char","String","Bool"]
59 ]
62makeConstructors :: Environment
63 -> [ADT]
64 -> Map.Map String (IO (Int, [Variable], [Type], Type))
65makeConstructors env datatypes = Map.fromList builtins
66 where
67 list t = (types env Map.! "_List") <| t
69 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
70 inst numTVars tipe = do
71 vars <- forM [1..numTVars] $ \_ -> var Flexible
72 let (args, result) = tipe (map VarN vars)
73 return (length args, vars, args, result)
75 tupleCtor n =
76 let name = "_Tuple" ++ show n
77 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
79 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
80 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
81 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
82 ] ++ map tupleCtor [0..9]
83 ++ concatMap (ctorToType env) datatypes
86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
87ctorToType env (name, tvars, ctors, _) =
88 zip (map fst ctors) (map inst ctors)
89 where
90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
91 inst ctor = do
92 ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
93 return (length args, Map.elems dict, args, tipe)
96 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
97 go (_, args) = do
98 types <- mapM (instantiator env) args
99 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
100 return (types, returnType)
103get :: Environment -> (Environment -> Map.Map String a) -> String -> a
104get env subDict key = Map.findWithDefault err key (subDict env)
105 where
106 err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
109freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
110freshDataScheme env name = get env constructor name
112instance ErrorList PP.Doc where
113 listMsg str = [PP.text str]
115instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
116instantiateType env sourceType dict =
117 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))
118 case result :: Either SomeException (Type, (VarDict, TypeDict)) of
119 Left someError -> throwError [ PP.text $ show someError ]
120 Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)
122instantiator :: Environment -> Src.Type
123 -> State.StateT (VarDict, TypeDict) IO Type
124instantiator env sourceType = go sourceType
125 where
126 go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
127 go sourceType =
128 case sourceType of
129 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
131 Src.Var x -> do
132 (dict, aliases) <- State.get
133 case (Map.lookup x dict, Map.lookup x aliases) of
134 (_, Just t) -> return t
135 (Just v, _) -> return (VarN v)
136 _ ->
137 do var <- State.liftIO $ namedVar flex x
138 State.put (Map.insert x var dict, aliases)
139 return (VarN var)
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 Src.Data name ts -> do
147 ts' <- mapM go ts
148 case (Map.lookup name (types env), Map.lookup name (aliases env)) of
149 (Just t, _) -> return $ foldl (<|) t ts'
150 (_, Just (tvars, t)) ->
151 let tvarLen = length tvars
152 msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
153 " type argument" ++ (if tvarLen == 1 then "" else "s") ++
154 " but was given " ++ show (length ts')
155 in if length ts' /= length tvars then error msg else
156 do (dict, aliases) <- State.get
157 let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
158 State.put (dict, aliases')
159 t' <- go t
160 State.put (dict, aliases)
161 return t'
162 _ -> error $ "\nCould not find type constructor '" ++
163 name ++ "' while checking types."
165 Src.Record fields ext -> do
166 fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
167 ext' <- case ext of
168 Nothing -> return $ TermN EmptyRecord1
169 Just x -> go (Src.Var x)
170 return $ TermN (Record1 fields' ext')