git.iko.soy/elk
on d7cdace help sign in
elk/compiler/Type/Environment.hs
143 lines 5.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 Data.List (isPrefixOf)
10import qualified Data.UnionFind.IO as UF
12import qualified SourceSyntax.Type as Src
13import SourceSyntax.Module (ADT)
14import Type.Type
16data Environment = Environment {
17 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
18 types :: Map.Map String Type,
19 value :: Map.Map String Type
22initialEnvironment :: [ADT] -> IO Environment
23initialEnvironment datatypes = do
24 types <- makeTypes datatypes
26 return $ Environment {
27 constructor = makeConstructors types datatypes,
28 types = types,
29 value = Map.empty
30 }
32makeTypes :: [ADT] -> IO (Map.Map String Type)
33makeTypes datatypes =
34 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
35 where
36 nameAndKind (name, tvars, _) = (name, length tvars)
38 makeCtor (name, kind) = do
39 ctor <- VarN <$> namedVar Constant name
40 return (name, ctor)
42 tuple n = ("_Tuple" ++ show n, n)
44 kind n names = map (\name -> (name, n)) names
46 builtins :: [(String,Int)]
47 builtins = concat [ map tuple [0..9]
48 , kind 1 ["_List","Signal"]
49 , kind 0 ["Int","Float","Char","Bool","Element","Text"
50 ,"Color","Order"]
51 ]
54makeConstructors :: Map.Map String Type
55 -> [ADT]
56 -> Map.Map String (IO (Int, [Variable], [Type], Type))
57makeConstructors types datatypes = Map.fromList builtins
58 where
59 list t = (types ! "_List") <| t
61 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
62 inst numTVars tipe = do
63 vars <- forM [1..numTVars] $ \_ -> var Flexible
64 let (args, result) = tipe (map VarN vars)
65 return (length args, vars, args, result)
67 tupleCtor n =
68 let name = "_Tuple" ++ show n
69 in (name, inst n $ \vs -> (vs, foldl (<|) (types ! name) vs))
71 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
72 builtins = [ ("[]" , inst 1 $ \ [t] -> ([], list t))
73 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
74 ] ++ map tupleCtor [0..9]
75 ++ concatMap (ctorToType tempEnv) datatypes
77 tempEnv = Environment { types = types, constructor = Map.empty, value = Map.empty }
79ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
80ctorToType env (name, tvars, ctors) =
81 zip (map fst ctors) (map inst ctors)
82 where
83 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
84 inst ctor = do
85 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
86 return (length args, Map.elems dict, args, tipe)
89 go :: (String, [Src.Type]) -> State.StateT (Map.Map String Variable) IO ([Type], Type)
90 go (ctor, args) = do
91 types <- mapM (instantiator env) args
92 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
93 return (types, returnType)
96get :: Environment -> (Environment -> Map.Map String a) -> String -> a
97get env subDict key = Map.findWithDefault err key (subDict env)
98 where
99 err = error $ "Could not find '" ++ key ++ "' in the type environment."
102freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
103freshDataScheme env name = get env constructor name
105instantiateType ::
106 Environment -> Src.Type -> Map.Map String Variable -> IO ([Variable], Type)
107instantiateType env sourceType dict =
108 do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
109 return (Map.elems dict', tipe)
111instantiator :: Environment -> Src.Type -> State.StateT (Map.Map String Variable) IO Type
112instantiator env sourceType = go sourceType
113 where
114 go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
115 go sourceType =
116 case sourceType of
117 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
119 Src.Var x -> do
120 dict <- State.get
121 case Map.lookup x dict of
122 Just var -> return (VarN var)
123 Nothing ->
124 do var <- State.liftIO $ namedVar flex x
125 State.put (Map.insert x var dict)
126 return (VarN var)
127 where
128 flex | "number" `isPrefixOf` x = Is Number
129 | "comparable" `isPrefixOf` x = Is Comparable
130 | "appendable" `isPrefixOf` x = Is Appendable
131 | otherwise = Flexible
133 Src.Data "String" [] ->
134 return (get env types "_List" <| get env types "Char")
136 Src.Data name ts -> do
137 ts' <- mapM go ts
138 return $ foldl (<|) (get env types name) ts'
140 Src.EmptyRecord -> return (TermN EmptyRecord1)
142 Src.Record fields ext ->
143 TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)