git.iko.soy/elk
on da346ea help sign in
elk/compiler/Type/Environment.hs
162 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.Map ((!))
9import Data.List (isPrefixOf)
10import qualified Data.UnionFind.IO as UF
12import qualified SourceSyntax.Type as Src
13import SourceSyntax.Module (ADT)
14import Type.Type
16type TypeDict = Map.Map String Type
17type VarDict = Map.Map String Variable
19data Environment = Environment {
20 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
21 aliases :: Map.Map String ([String], Src.Type),
22 types :: TypeDict,
23 value :: TypeDict
26initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
27initialEnvironment datatypes aliases = do
28 types <- makeTypes datatypes
29 let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
30 env = Environment {
31 constructor = Map.empty,
32 value = Map.empty,
33 types = types,
34 aliases = aliases' }
36 return $ env { constructor = makeConstructors env datatypes }
38makeTypes :: [ADT] -> IO TypeDict
39makeTypes datatypes =
40 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
41 where
42 nameAndKind (name, tvars, _) = (name, length tvars)
44 makeCtor (name, kind) = do
45 ctor <- VarN <$> namedVar Constant name
46 return (name, ctor)
48 tuple n = ("_Tuple" ++ show n, n)
50 kind n names = map (\name -> (name, n)) names
52 builtins :: [(String,Int)]
53 builtins = concat [ map tuple [0..9]
54 , kind 1 ["_List","Signal"]
55 , kind 0 ["Int","Float","Char","Bool"]
56 ]
59makeConstructors :: Environment
60 -> [ADT]
61 -> Map.Map String (IO (Int, [Variable], [Type], Type))
62makeConstructors env datatypes = Map.fromList builtins
63 where
64 list t = (types env ! "_List") <| t
66 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
67 inst numTVars tipe = do
68 vars <- forM [1..numTVars] $ \_ -> var Flexible
69 let (args, result) = tipe (map VarN vars)
70 return (length args, vars, args, result)
72 tupleCtor n =
73 let name = "_Tuple" ++ show n
74 in (name, inst n $ \vs -> (vs, foldl (<|) (types env ! name) vs))
76 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
77 builtins = [ ("[]" , inst 1 $ \ [t] -> ([], list t))
78 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
79 ] ++ map tupleCtor [0..9]
80 ++ concatMap (ctorToType env) datatypes
83ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
84ctorToType env (name, tvars, ctors) =
85 zip (map fst ctors) (map inst ctors)
86 where
87 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
88 inst ctor = do
89 ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
90 return (length args, Map.elems dict, args, tipe)
93 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
94 go (ctor, args) = do
95 types <- mapM (instantiator env) args
96 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
97 return (types, returnType)
100get :: Environment -> (Environment -> Map.Map String a) -> String -> a
101get env subDict key = Map.findWithDefault err key (subDict env)
102 where
103 err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
106freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
107freshDataScheme env name = get env constructor name
109instantiateType ::
110 Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
111instantiateType env sourceType dict =
112 do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)
113 return (Map.elems dict', tipe)
115instantiator :: Environment -> Src.Type
116 -> State.StateT (VarDict, TypeDict) IO Type
117instantiator env sourceType = go sourceType
118 where
119 go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
120 go sourceType =
121 case sourceType of
122 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
124 Src.Var x -> do
125 (dict, aliases) <- State.get
126 case Map.lookup x dict of
127 Just var -> return (VarN var)
128 Nothing ->
129 case Map.lookup x aliases of
130 Just t -> return t
131 Nothing ->
132 do var <- State.liftIO $ namedVar flex x
133 State.put (Map.insert x var dict, aliases)
134 return (VarN var)
135 where
136 flex | "number" `isPrefixOf` x = Is Number
137 | "comparable" `isPrefixOf` x = Is Comparable
138 | "appendable" `isPrefixOf` x = Is Appendable
139 | otherwise = Flexible
141 Src.Data "String" [] ->
142 return (get env types "_List" <| get env types "Char")
144 Src.Data name ts -> do
145 ts' <- mapM go ts
146 case Map.lookup name (types env) of
147 Just t -> return $ foldl (<|) t ts'
148 Nothing ->
149 case Map.lookup name (aliases env) of
150 Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."
151 Just (tvars, t) ->
152 let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++
153 " but was given " ++ show (length ts')
154 in if length ts' /= length tvars then error msg else
155 do (dict, aliases) <- State.get
156 State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')
157 go t
159 Src.EmptyRecord -> return (TermN EmptyRecord1)
161 Src.Record fields ext ->
162 TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)