git.iko.soy/elk
on fd63aff help sign in
elk/compiler/Type/Inference.hs
60 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 as 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 let insert (name,method) dict = Map.insertWith (++) name [method] dict
27 localImports = foldr insert Map.empty (imports modul)
28 interfaces = Map.intersectionWithKey Module.canonicalize localImports interfaces'
30-- mapM print (concatMap iAdts (Map.elems interfaces))
32 env <- Env.initialEnvironment
33 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
34 (aliases modul ++ concatMap iAliases (Map.elems interfaces))
35 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
36 do (_, vars, args, result) <- Env.freshDataScheme env name
37 return (name, (vars, foldr (T.==>) result args))
39-- mapM print (map Map.toList $ Map.elems locals)
40-- mapM print (imports modul)
42 importedVars <-
43 forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
44 (,) name `fmap` Env.instantiateType env tipe Map.empty
46 let allTypes = ctors ++ importedVars
47 vars = concatMap (fst . snd) allTypes
48 header = Map.map snd (Map.fromList allTypes)
49 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
51 fvar <- T.var T.Flexible
52 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
53 --print =<< T.extraPretty constraint
55 state <- execStateT (Solve.solve constraint) TS.initialState
56 let errors = TS.sErrors state
57 if null errors
58 then return $ Right (Map.difference (TS.sSavedEnv state) header)
59 else Left `fmap` sequence errors