git.iko.soy/elk
on e53ebfc help sign in
elk/compiler/Type/Inference.hs
57 lines 2.4 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Inference where
4import qualified Data.Map as Map
6import qualified Type.Type as T
7import qualified Type.Environment as Env
8import qualified Type.Constrain.Expression as TcExpr
9import qualified Type.Solve as Solve
11import SourceSyntax.Module as Module
12import SourceSyntax.Annotation (noneNoDocs)
13import SourceSyntax.Type (Type)
14import Text.PrettyPrint
15import qualified Type.State as TS
16import qualified Type.ExtraChecks as Check
17import Control.Monad.State (execStateT, forM)
18import Control.Monad.Error (runErrorT, liftIO)
19import qualified Type.Alias as Alias
21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22 -- the IO monad. I don't think that'd be worthwhile.
25infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)
26infer interfaces modul = unsafePerformIO $ do
27 env <- Env.initialEnvironment
28 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
29 (aliases modul ++ concatMap iAliases (Map.elems interfaces))
30 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
31 do (_, vars, args, result) <- Env.freshDataScheme env name
32 return (name, (vars, foldr (T.==>) result args))
34 attemptConstraint <- runErrorT $ do
35 importedVars <-
36 forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
37 (,) name `fmap` Env.instantiateType env tipe Map.empty
39 let allTypes = ctors ++ importedVars
40 vars = concatMap (fst . snd) allTypes
41 header = Map.map snd (Map.fromList allTypes)
42 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
44 fvar <- liftIO $ T.var T.Flexible
45 c <- TcExpr.constrain env (program modul) (T.VarN fvar)
46 return (header, environ c)
48 case attemptConstraint of
49 Left err -> return $ Left err
50 Right (header, constraint) -> do
51 state <- execStateT (Solve.solve constraint) TS.initialState
52 let rules = Alias.rules interfaces (aliases modul) (imports modul)
53 case TS.sErrors state of
54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
55 [] -> case Check.portTypes rules (program modul) of
56 Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
57 Left err -> return (Left err)