git.iko.soy/elk
on 2edcced help sign in
elk/compiler/Type/Inference.hs
58 lines 2.4 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.Location (Located, noneNoDocs)
14import SourceSyntax.PrettyPrint
15import SourceSyntax.Type (Type)
16import Text.PrettyPrint
17import qualified Type.State as TS
18import Type.ExtraChecks (extraChecks)
19import Control.Monad.State (execStateT, forM)
20import Control.Monad.Error (runErrorT, liftIO)
21import Control.Arrow (second)
22import qualified Type.Alias as Alias
24import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
25 -- the IO monad. I don't think that'd be worthwhile.
28infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)
29infer interfaces modul = unsafePerformIO $ do
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 attemptConstraint <- runErrorT $ do
38 importedVars <-
39 forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
40 (,) name `fmap` Env.instantiateType env tipe Map.empty
42 let allTypes = ctors ++ importedVars
43 vars = concatMap (fst . snd) allTypes
44 header = Map.map snd (Map.fromList allTypes)
45 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
47 fvar <- liftIO $ T.var T.Flexible
48 c <- TcExpr.constrain env (program modul) (T.VarN fvar)
49 return (header, environ c)
51 case attemptConstraint of
52 Left err -> return $ Left err
53 Right (header, constraint) -> do
54 state <- execStateT (Solve.solve constraint) TS.initialState
55 let rules = Alias.rules interfaces modul
56 case TS.sErrors state of
57 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
58 [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)