git.iko.soy/elk
on 727d708 help sign in
elk/compiler/Type/Environment.hs
127 lines 4.5 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 Type.Type
15data Environment = Environment {
16 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
17 types :: Map.Map String Type,
18 value :: Map.Map String Type
21initialEnvironment :: [(String, [String], [(String,[Src.Type])])] -> IO Environment
22initialEnvironment datatypes = do
23 types <- makeTypes datatypes
25 return $ Environment {
26 constructor = makeConstructors types,
27 types = types,
28 value = Map.empty
29 }
31makeTypes :: [(String, [String], [(String, [Src.Type])])] -> IO (Map.Map String Type)
32makeTypes datatypes =
33 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
34 where
35 nameAndKind (name, tvars, _) = (name, length tvars)
37 makeCtor (name, kind) = do
38 ctor <- VarN <$> namedVar Constant name
39 return (name, ctor)
41 tuple n = ("_Tuple" ++ show n, n)
43 kind n names = map (\name -> (name, n)) names
45 builtins :: [(String,Int)]
46 builtins = concat [ map tuple [0..9]
47 , kind 1 ["_List","Maybe","Signal"]
48 , kind 0 ["Int","Float","Char","Bool","Element","Text","Color","Order"]
49 ]
52makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], [Type], Type))
53makeConstructors types = Map.fromList builtins
54 where
55 list t = (types ! "_List") <| t
56 maybe t = (types ! "Maybe") <| t
58 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
59 inst numTVars tipe = do
60 vars <- forM [1..numTVars] $ \_ -> var Flexible
61 let (args, result) = tipe (map VarN vars)
62 return (length args, vars, args, result)
64 tupleCtor n =
65 let name = "_Tuple" ++ show n
66 in (name, inst n $ \vs -> (vs, foldl (<|) (types ! name) vs))
68 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
69 builtins = [ ("Nothing", inst 1 $ \ [t] -> ([], maybe t))
70 , ("Just" , inst 1 $ \ [t] -> ([t], maybe t))
71 , ("[]" , inst 1 $ \ [t] -> ([], list t))
72 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
73 ] ++ map tupleCtor [0..9]
76get :: Environment -> (Environment -> Map.Map String a) -> String -> a
77get env subDict key = Map.findWithDefault err key (subDict env)
78 where
79 err = error $ "Could not find '" ++ key ++ "' in the type environment."
82freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
83freshDataScheme env name = get env constructor name
86instantiateType :: Environment -> Src.Type -> IO Type
87instantiateType env sourceType =
88 snd <$> instantiateTypeWithContext env sourceType Map.empty
90instantiateTypeWithContext :: Environment
91 -> Src.Type
92 -> Map.Map String Variable
93 -> IO ([Variable], Type)
94instantiateTypeWithContext env sourceType dict =
95 do (tipe, dict') <- State.runStateT (go sourceType) dict
96 return (Map.elems dict', tipe)
97 where
98 go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
99 go sourceType =
100 case sourceType of
101 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
103 Src.Var x -> do
104 dict <- State.get
105 case Map.lookup x dict of
106 Just var -> return (VarN var)
107 Nothing ->
108 do var <- State.liftIO $ namedVar flex x
109 State.put (Map.insert x var dict)
110 return (VarN var)
111 where
112 flex | "number" `isPrefixOf` x = Is Number
113 | "comparable" `isPrefixOf` x = Is Comparable
114 | "appendable" `isPrefixOf` x = Is Appendable
115 | otherwise = Flexible
117 Src.Data "String" [] ->
118 return (get env types "_List" <| get env types "Char")
120 Src.Data name ts -> do
121 ts' <- mapM go ts
122 return $ foldl (<|) (get env types name) ts'
124 Src.EmptyRecord -> return (TermN EmptyRecord1)
126 Src.Record fields ext ->
127 TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)