git.iko.soy/elk
on 4e7ef5f help sign in
elk/compiler/Type/Environment.hs
141 lines 5.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.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], 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","Order"]
48 ]
51makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], [Type], Type))
52makeConstructors types = Map.fromList builtins
53 where
54 list t = (types ! "_List") <| t
55 maybe t = (types ! "Maybe") <| t
56 bool = types ! "Bool"
57 int = types ! "Int"
58 float = types ! "Float"
59 order = types ! "Order"
61 instance' :: IO Variable -> Int -> ([Type] -> ([Type], Type))
62 -> IO (Int, [Variable], [Type], Type)
63 instance' var numTVars tipe = do
64 vars <- forM [1..numTVars] $ \_ -> var
65 let (args, result) = tipe (map VarN vars)
66 return (length args, vars, args, result)
68 inst = instance' flexibleVar
69 nmbr = instance' number 1
70 cmpr = instance' comparable 1
71 apnd = instance' appendable 1
73 tupleCtor n =
74 let name = "_Tuple" ++ show n
75 in (name, inst n $ \vs -> (vs, foldl (<|) (types ! name) vs))
77 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
78 builtins = [ ("Nothing", inst 1 $ \ [t] -> ([], maybe t))
79 , ("Just" , inst 1 $ \ [t] -> ([t], maybe t))
80 , ("[]" , inst 1 $ \ [t] -> ([], list t))
81 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
82 , ("div" , inst 0 $ \ [] -> ([int, int], int))
83 , ("/" , inst 0 $ \ [] -> ([float, float], float))
84 , ("+" , nmbr $ \ [t] -> ([t, t], t))
85 , ("-" , nmbr $ \ [t] -> ([t, t], t))
86 , ("*" , nmbr $ \ [t] -> ([t, t], t))
87 , ("<" , cmpr $ \ [t] -> ([t, t], bool))
88 , (">" , cmpr $ \ [t] -> ([t, t], bool))
89 , ("<=" , cmpr $ \ [t] -> ([t, t], bool))
90 , (">=" , cmpr $ \ [t] -> ([t, t], bool))
91 , ("==" , cmpr $ \ [t] -> ([t, t], bool))
92 , ("/=" , cmpr $ \ [t] -> ([t, t], bool))
93 , ("compare", cmpr $ \ [t] -> ([t, t], order))
94 , ("otherwise", inst 0 $ \ [] -> ([], bool))
95 ] ++ map tupleCtor [0..9]
98get :: Environment -> (Environment -> Map.Map String a) -> String -> a
99get env subDict key = Map.findWithDefault err key (subDict env)
100 where
101 err = error $ "Could not find '" ++ key ++ "' in the type environment."
104freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
105freshDataScheme env name = get env constructor name
108instantiateType :: Environment -> Src.Type -> IO Type
109instantiateType env sourceType =
110 snd <$> instantiateTypeWithContext env sourceType Map.empty
112instantiateTypeWithContext :: Environment
113 -> Src.Type
114 -> Map.Map String Variable
115 -> IO ([Variable], Type)
116instantiateTypeWithContext env sourceType dict =
117 do (tipe, dict') <- State.runStateT (go sourceType) dict
118 return (Map.elems dict', tipe)
119 where
120 go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
121 go sourceType =
122 case sourceType of
123 Src.Lambda t1 t2 -> TermN <$> (Fun1 <$> go t1 <*> go t2)
125 Src.Var x -> do
126 dict <- State.get
127 case Map.lookup x dict of
128 Just var -> return (VarN var)
129 Nothing -> do
130 var <- State.liftIO $ namedVar Flexible x -- should this be Constant or Flexible?
131 State.put (Map.insert x var dict)
132 return (VarN var)
134 Src.Data name ts -> do
135 ts' <- mapM go ts
136 return $ foldl (\tyFn ty -> TermN $ App1 tyFn ty) (get env types name) ts'
138 Src.EmptyRecord -> return (TermN EmptyRecord1)
140 Src.Record fields ext ->
141 TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)