git.iko.soy/elk
on a268421 help sign in
elk/compiler/Type/Environment.hs
161 lines 6.1 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 $ "Could 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 of
126 Just var -> return (VarN var)
127 Nothing ->
128 case Map.lookup x aliases of
129 Just t -> return t
130 Nothing ->
131 do var <- State.liftIO $ namedVar flex x
132 State.put (Map.insert x var dict, aliases)
133 return (VarN var)
134 where
135 flex | "number" `isPrefixOf` x = Is Number
136 | "comparable" `isPrefixOf` x = Is Comparable
137 | "appendable" `isPrefixOf` x = Is Appendable
138 | otherwise = Flexible
140 Src.Data "String" [] ->
141 return (get env types "_List" <| get env types "Char")
143 Src.Data name ts -> do
144 ts' <- mapM go ts
145 case Map.lookup name (types env) of
146 Just t -> return $ foldl (<|) t ts'
147 Nothing ->
148 case Map.lookup name (aliases env) of
149 Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."
150 Just (tvars, t) ->
151 let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++
152 " but was given " ++ show (length ts')
153 in if length ts' /= length tvars then error msg else
154 do (dict, aliases) <- State.get
155 State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')
156 go t
158 Src.EmptyRecord -> return (TermN EmptyRecord1)
160 Src.Record fields ext ->
161 TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)