git.iko.soy/elk
on eb2a032 help sign in
elk/compiler/Type/Environment.hs
171 lines 6.6 kB history raw
1module Type.Environment where
3import Control.Applicative ((<$>), (<*>))
4import Control.Exception (try, SomeException)
5import Control.Monad
6import Control.Monad.Trans.Error (ErrorList(..))
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 Data.UnionFind.IO as UF
13import qualified Text.PrettyPrint as PP
15import qualified SourceSyntax.Type as Src
16import SourceSyntax.Module (ADT)
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] -> [(String, [String], Src.Type)] -> 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, kind) = 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","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 (ctor, 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 "String" [] ->
147 return (get env types "_List" <| get env types "Char")
149 Src.Data name ts -> do
150 ts' <- mapM go ts
151 case (Map.lookup name (types env), Map.lookup name (aliases env)) of
152 (Just t, _) -> return $ foldl (<|) t ts'
153 (_, Just (tvars, t)) ->
154 let tvarLen = length tvars
155 msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
156 " type argument" ++ (if tvarLen == 1 then "" else "s") ++
157 " but was given " ++ show (length ts')
158 in if length ts' /= length tvars then error msg else
159 do (dict, aliases) <- State.get
160 let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
161 State.put (dict, aliases')
162 t' <- go t
163 State.put (dict, aliases)
164 return t'
165 _ -> error $ "\nCould not find type constructor '" ++
166 name ++ "' while checking types."
168 Src.EmptyRecord -> return (TermN EmptyRecord1)
170 Src.Record fields ext ->
171 TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)