git.iko.soy/elk
on befb3df help sign in
elk/src/Type/Environment.hs
263 lines 6.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Environment
4 ( Env
5 , Dict
6 , initialize
7 , get, getType, freshDataScheme, ctorNames
8 , addValues
9 , instantiateType
10 )
11 where
13import Control.Monad (foldM)
14import qualified Control.Monad.State as State
15import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Set as Set
18import Data.Text (Text)
20import qualified AST.Helpers as Help
21import qualified AST.Type as T
22import qualified AST.Variable as Var
23import qualified AST.Module as Module
24import Type.Type
28-- ENVIRONMENT
31data Env =
32 Env
33 { _ctor :: Dict Instantiator
34 , _types :: Dict Type
35 , _value :: Dict Type
36 }
39type Instantiator =
40 IO (Int, [Variable], [Type], Type)
43type Dict a =
44 Map.Map Text a
47initialize :: [Module.CanonicalUnion] -> IO Env
48initialize unions =
49 do types <- makeTypes unions
50 let env =
51 Env
52 { _ctor = Map.empty
53 , _value = Map.empty
54 , _types = types
55 }
56 return $ env { _ctor = makeCtors env unions }
60-- TYPES
63makeTypes :: [Module.CanonicalUnion] -> IO (Dict Type)
64makeTypes unions =
65 do builtinDict <- Map.fromList <$> mapM makeBuiltin builtinTypes
66 foldM addImported builtinDict unions
69addImported :: Dict Type -> (Var.Canonical, unionInfo) -> IO (Dict Type)
70addImported dict ( var, _ ) =
71 do atom <- mkAtom var
72 return (Map.insert (Var.toText var) (VarN atom) dict)
75makeBuiltin :: (Text, Int) -> IO (Text, Type)
76makeBuiltin (name, _) =
77 do atom <- mkAtom (Var.builtin name)
78 return (name, VarN atom)
81builtinTypes :: [(Text, Int)]
82builtinTypes =
83 concat
84 [ map tuple [0..9]
85 , kind 1 ["List"]
86 , kind 0 ["Int","Float","Char","String","Bool"]
87 ]
88 where
89 tuple size = ( Help.makeTuple size, size )
90 kind n names = map (\name -> (name, n)) names
94-- CONSTRUCTORS
97makeCtors :: Env -> [Module.CanonicalUnion] -> Dict Instantiator
98makeCtors env unions =
99 let
100 list t =
101 getType env "List" <| t
103 inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator
104 inst numTVars tipe =
105 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]
106 let (args, result) = tipe (map (VarN) vars)
107 return (length args, vars, args, result)
109 tupleCtor size =
110 let
111 name =
112 Help.makeTuple size
113 in
114 (name, inst size $ \vs -> (vs, foldl (<|) (getType env name) vs))
116 builtins :: Dict Instantiator
117 builtins =
118 Map.fromList $
119 [ ("[]", inst 1 $ \ [t] -> ([], list t))
120 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
121 ]
122 ++ map tupleCtor [0..9]
123 in
124 List.foldl' (makeCtorsHelp env) builtins unions
127type VarDict =
128 Map.Map Text Variable
131makeCtorsHelp :: Env -> Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator
132makeCtorsHelp env constructorDict ( var, (rawTypeVars, ctors) ) =
133 let
134 inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator
135 inst ctorDict (name, rawArgs) =
136 Map.insert
137 (Var.toText name)
138 ( do ((args, tipe), dict) <- State.runStateT (go rawArgs) Map.empty
139 return ( length args, Map.elems dict, args, tipe )
140 )
141 ctorDict
143 tvars =
144 map T.Var rawTypeVars
146 go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)
147 go args =
148 do types <- mapM (instantiator Flex env) args
149 returnType <- instantiator Flex env (T.App (T.Type var) tvars)
150 return (types, returnType)
151 in
152 List.foldl' inst constructorDict ctors
156-- ACCESS TYPES
159{-# INLINE get #-}
160get :: Dict a -> Text -> a
161get dict var =
162 dict Map.! var
165getType :: Env -> Text -> Type
166getType env var =
167 get (_types env) var
170freshDataScheme :: Env -> Text -> Instantiator
171freshDataScheme env var =
172 get (_ctor env) var
175ctorNames :: Env -> [Text]
176ctorNames env =
177 Map.keys (_ctor env)
181-- UPDATE ENVIRONMENT
184addValues :: VarDict -> Env -> Env
185addValues newValues env =
186 env { _value = Map.union (_value env) (Map.map VarN newValues) }
190-- INSTANTIATE TYPES
193instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)
194instantiateType flex env sourceType =
195 State.runStateT (instantiator flex env sourceType) Map.empty
198instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type
199instantiator flex env sourceType =
200 instantiatorHelp flex env Set.empty sourceType
203instantiatorHelp :: Flex -> Env -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
204instantiatorHelp flex env aliasVars sourceType =
205 let
206 go =
207 instantiatorHelp flex env aliasVars
208 in
209 case sourceType of
210 T.Lambda t1 t2 ->
211 (==>) <$> go t1 <*> go t2
213 T.Var name ->
214 if Set.member name aliasVars then
215 return (PlaceHolder name)
217 else
218 do dict <- State.get
219 case Map.lookup name (_value env) of
220 Just tipe ->
221 return tipe
223 Nothing ->
224 case Map.lookup name dict of
225 Just variable ->
226 return (VarN variable)
228 Nothing ->
229 do variable <- State.liftIO (mkNamedVar flex name)
230 State.put (Map.insert name variable dict)
231 return (VarN variable)
233 T.Aliased name args aliasType ->
234 do targs <- traverse (traverse go) args
235 realType <-
236 case aliasType of
237 T.Filled tipe ->
238 instantiatorHelp flex env Set.empty tipe
240 T.Holey tipe ->
241 instantiatorHelp flex env (Set.fromList (map fst args)) tipe
243 return (AliasN name targs realType)
245 T.Type name ->
246 return (getType env (Var.toText name))
248 T.App func args ->
249 do tfunc <- go func
250 targs <- traverse go args
251 return $ foldl (<|) tfunc targs
253 T.Record fields ext ->
254 do tfields <- traverse go (Map.fromList fields)
255 text <-
256 case ext of
257 Nothing ->
258 return $ TermN EmptyRecord1
260 Just extType ->
261 go extType
263 return $ TermN (Record1 tfields text)