git.iko.soy/elk
on 97bd68a help sign in
elk/compiler/Type/Inference.hs
59 lines 2.3 kB history raw
1module Type.Inference where
3import qualified Data.Map as Map
5import qualified Type.Type as T
6import qualified Type.Environment as Env
7import qualified Type.Constrain.Expression as TcExpr
8import qualified Type.Constrain.Declaration as TcDecl
9import qualified Type.Solve as Solve
11import SourceSyntax.Module
12import qualified SourceSyntax.Expression as Expr
13import SourceSyntax.PrettyPrint
14import Text.PrettyPrint
15import qualified Type.State as TS
16import Control.Monad.State
17import Control.Arrow (second)
18import Transform.SortDefinitions as Sort
20import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
21 -- the IO monad. Not sure if that'd be worthwhile.
24infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
25infer interfaces modul = unsafePerformIO $ do
26 env <- Env.initialEnvironment (datatypes modul)
27 var <- T.flexibleVar
28 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
29 do (_, vars, tipe) <- Env.freshDataScheme env name
30 return (name, (vars, tipe))
32 let combine name importMethod interface =
33 let tipes = iTypes interface in
34 case importMethod of
35 As alias -> Map.mapKeys (\v -> alias ++ "." ++ v) tipes
36 Hiding hidens -> foldr Map.delete tipes hidens
37 Importing visibles ->
38 Map.intersection tipes (Map.fromList [ (v,()) | v <- visibles ])
40 locals = Map.intersectionWithKey combine (Map.fromList (imports modul)) interfaces
42 mapM print (imports modul)
44 importedVars <-
45 forM (concatMap Map.toList $ Map.elems locals) $ \(name,tipe) ->
46 (,) name `fmap` Env.instantiateTypeWithContext env tipe Map.empty
48 let allTypes = ctors ++ importedVars
49 vars = concatMap (fst . snd) allTypes
50 header = Map.map snd (Map.fromList allTypes)
51 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
52 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
53-- print =<< T.extraPretty constraint
54 state <- execStateT (Solve.solve constraint) TS.initialState
55 let errors = TS.sErrors state
56 if null errors
57 then return $ Right (Map.difference (TS.sSavedEnv state) header)
58 else Left `fmap` sequence errors