git.iko.soy/elk
on fbad8ea help sign in
elk/compiler/Type/Environment.hs
163 lines 6.2 kB history raw
1module Type.Environment where
3import Control.Applicative ((<$>), (<*>))
4import Control.Monad
5import qualified Control.Monad.State as State
6import qualified Data.Traversable as Traverse
7import qualified Data.Map as Map
8import Data.List (isPrefixOf)
9import qualified Data.UnionFind.IO as UF
11import qualified SourceSyntax.Type as Src
12import SourceSyntax.Module (ADT)
13import Type.Type
15type TypeDict = Map.Map String Type
16type VarDict = Map.Map String Variable
18data Environment = Environment {
19 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
20 aliases :: Map.Map String ([String], Src.Type),
21 types :: TypeDict,
22 value :: TypeDict
25initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
26initialEnvironment datatypes aliases = do
27 types <- makeTypes datatypes
28 let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
29 env = Environment {
30 constructor = Map.empty,
31 value = Map.empty,
32 types = types,
33 aliases = aliases' }
35 return $ env { constructor = makeConstructors env datatypes }
37makeTypes :: [ADT] -> IO TypeDict
38makeTypes datatypes =
39 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
40 where
41 nameAndKind (name, tvars, _) = (name, length tvars)
43 makeCtor (name, kind) = do
44 ctor <- VarN <$> namedVar Constant name
45 return (name, ctor)
47 tuple n = ("_Tuple" ++ show n, n)
49 kind n names = map (\name -> (name, n)) names
51 builtins :: [(String,Int)]
52 builtins = concat [ map tuple [0..9]
53 , kind 1 ["_List"]
54 , kind 0 ["Int","Float","Char","Bool"]
55 ]
58makeConstructors :: Environment
59 -> [ADT]
60 -> Map.Map String (IO (Int, [Variable], [Type], Type))
61makeConstructors env datatypes = Map.fromList builtins
62 where
63 list t = (types env Map.! "_List") <| t
65 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
66 inst numTVars tipe = do
67 vars <- forM [1..numTVars] $ \_ -> var Flexible
68 let (args, result) = tipe (map VarN vars)
69 return (length args, vars, args, result)
71 tupleCtor n =
72 let name = "_Tuple" ++ show n
73 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
75 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
76 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
77 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
78 ] ++ map tupleCtor [0..9]
79 ++ concatMap (ctorToType env) datatypes
82ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
83ctorToType env (name, tvars, ctors) =
84 zip (map fst ctors) (map inst ctors)
85 where
86 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
87 inst ctor = do
88 ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
89 return (length args, Map.elems dict, args, tipe)
92 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
93 go (ctor, args) = do
94 types <- mapM (instantiator env) args
95 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
96 return (types, returnType)
99get :: Environment -> (Environment -> Map.Map String a) -> String -> a
100get env subDict key = Map.findWithDefault err key (subDict env)
101 where
102 err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
105freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
106freshDataScheme env name = get env constructor name
108instantiateType ::
109 Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
110instantiateType env sourceType dict =
111 do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)
112 return (Map.elems dict', tipe)
114instantiator :: Environment -> Src.Type
115 -> State.StateT (VarDict, TypeDict) IO Type
116instantiator env sourceType = go sourceType
117 where
118 go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
119 go sourceType =
120 case sourceType of
121 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
123 Src.Var x -> do
124 (dict, aliases) <- State.get
125 case (Map.lookup x dict, Map.lookup x aliases) of
126 (_, Just t) -> return t
127 (Just v, _) -> return (VarN v)
128 _ ->
129 do var <- State.liftIO $ namedVar flex x
130 State.put (Map.insert x var dict, aliases)
131 return (VarN var)
132 where
133 flex | "number" `isPrefixOf` x = Is Number
134 | "comparable" `isPrefixOf` x = Is Comparable
135 | "appendable" `isPrefixOf` x = Is Appendable
136 | otherwise = Flexible
138 Src.Data "String" [] ->
139 return (get env types "_List" <| get env types "Char")
141 Src.Data name ts -> do
142 ts' <- mapM go ts
143 case (Map.lookup name (types env), Map.lookup name (aliases env)) of
144 (Just t, _) -> return $ foldl (<|) t ts'
145 (_, Just (tvars, t)) ->
146 let tvarLen = length tvars
147 msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
148 " type argument" ++ (if tvarLen == 1 then "" else "s") ++
149 " but was given " ++ show (length ts')
150 in if length ts' /= length tvars then error msg else
151 do (dict, aliases) <- State.get
152 let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
153 State.put (dict, aliases')
154 t' <- go t
155 State.put (dict, aliases)
156 return t'
157 _ -> error $ "\nCould not find type constructor '" ++
158 name ++ "' while checking types."
160 Src.EmptyRecord -> return (TermN EmptyRecord1)
162 Src.Record fields ext ->
163 TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)