git.iko.soy/elk
on eaa751d help sign in
elk/compiler/Type/Environment.hs
117 lines 4.0 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 qualified Data.UnionFind.IO as UF
11import qualified SourceSyntax.Type as Src
12import Type.Type
14data Environment = Environment {
15 constructor :: Map.Map String (IO (Int, [Variable], Type)),
16 types :: Map.Map String Type,
17 value :: Map.Map String Type
20initialEnvironment :: [(String, [String], [(String,[Src.Type])])] -> IO Environment
21initialEnvironment datatypes = do
22 types <- makeTypes datatypes
24 return $ Environment {
25 constructor = makeConstructors types,
26 types = types,
27 value = Map.empty
28 }
30makeTypes :: [(String, [String], [(String, [Src.Type])])] -> IO (Map.Map String Type)
31makeTypes datatypes =
32 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
33 where
34 nameAndKind (name, tvars, _) = (name, length tvars)
36 makeCtor (name, kind) = do
37 ctor <- VarN <$> namedVar Constant name
38 return (name, ctor)
40 tuple n = ("_Tuple" ++ show n, n)
42 kind n names = map (\name -> (name, n)) names
44 builtins :: [(String,Int)]
45 builtins = concat [ map tuple [0..9]
46 , kind 1 ["_List","Maybe","Signal"]
47 , kind 0 ["Int","Float","Char","Bool","Element"]
48 ]
51makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], Type))
52makeConstructors types = Map.fromList builtins
53 where
54 list t = (types ! "_List") <| t
55 maybe t = (types ! "Maybe") <| t
57 inst :: Int -> Int -> ([Type] -> Type) -> IO (Int, [Variable], Type)
58 inst kind numTVars tipe = do
59 vars <- forM [1..numTVars] $ \_ -> flexibleVar
60 return (kind, vars, tipe $ map VarN vars)
62 tupleCtor n =
63 let name = "_Tuple" ++ show n
64 in (name, inst n n $ \vs -> foldr (==>) (foldl (<|) (types ! name) vs) vs)
66 builtins :: [ (String, IO (Int, [Variable], Type)) ]
67 builtins = [ ("Nothing", inst 0 1 $ \ [t] -> maybe t)
68 , ("Just" , inst 1 1 $ \ [t] -> t ==> maybe t)
69 , ("[]" , inst 0 1 $ \ [t] -> list t)
70 , ("::" , inst 2 1 $ \ [t] -> t ==> list t ==> list t)
71 ] ++ map tupleCtor [0..9]
74get :: Environment -> (Environment -> Map.Map String a) -> String -> a
75get env subDict key = Map.findWithDefault err key (subDict env)
76 where
77 err = error $ "Could not find '" ++ key ++ "' in the type environment."
80freshDataScheme :: Environment -> String -> IO (Int, [Variable], Type)
81freshDataScheme env name = get env constructor name
84instantiateType :: Environment -> Src.Type -> IO Type
85instantiateType env sourceType =
86 snd <$> instantiateTypeWithContext env sourceType Map.empty
88instantiateTypeWithContext :: Environment
89 -> Src.Type
90 -> Map.Map String Variable
91 -> IO ([Variable], Type)
92instantiateTypeWithContext env sourceType dict =
93 do (tipe, dict') <- State.runStateT (go sourceType) dict
94 return (Map.elems dict', tipe)
95 where
96 go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
97 go sourceType =
98 case sourceType of
99 Src.Lambda t1 t2 -> TermN <$> (Fun1 <$> go t1 <*> go t2)
101 Src.Var x -> do
102 dict <- State.get
103 case Map.lookup x dict of
104 Just var -> return (VarN var)
105 Nothing -> do
106 var <- State.liftIO $ namedVar Flexible x -- should this be Constant or Flexible?
107 State.put (Map.insert x var dict)
108 return (VarN var)
110 Src.Data name ts -> do
111 ts' <- mapM go ts
112 return $ foldl (\tyFn ty -> TermN $ App1 tyFn ty) (get env types name) ts'
114 Src.EmptyRecord -> return (TermN EmptyRecord1)
116 Src.Record fields ext ->
117 TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)