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