2014-01-04 09:54:46 +00:00
|
|
|
{-# OPTIONS_GHC -W #-}
|
2013-07-15 22:38:31 +00:00
|
|
|
module Type.Inference where
|
|
|
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
|
|
import qualified Type.Type as T
|
|
|
|
import qualified Type.Environment as Env
|
|
|
|
import qualified Type.Constrain.Expression as TcExpr
|
|
|
|
import qualified Type.Solve as Solve
|
|
|
|
|
2013-07-26 10:56:36 +00:00
|
|
|
import SourceSyntax.Module as Module
|
2014-02-09 23:17:33 +00:00
|
|
|
import SourceSyntax.Annotation (noneNoDocs)
|
2013-08-21 21:23:11 +00:00
|
|
|
import SourceSyntax.Type (Type)
|
2013-07-15 22:38:31 +00:00
|
|
|
import Text.PrettyPrint
|
|
|
|
import qualified Type.State as TS
|
2014-01-05 09:41:40 +00:00
|
|
|
import qualified Type.ExtraChecks as Check
|
2013-08-26 03:23:49 +00:00
|
|
|
import Control.Monad.State (execStateT, forM)
|
|
|
|
import Control.Monad.Error (runErrorT, liftIO)
|
2013-08-22 02:08:03 +00:00
|
|
|
import qualified Type.Alias as Alias
|
2013-07-15 22:38:31 +00:00
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
|
2013-07-29 09:53:45 +00:00
|
|
|
-- the IO monad. I don't think that'd be worthwhile.
|
2013-07-15 22:38:31 +00:00
|
|
|
|
2013-07-17 17:29:27 +00:00
|
|
|
|
2014-01-03 07:53:30 +00:00
|
|
|
infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)
|
2013-07-29 09:53:45 +00:00
|
|
|
infer interfaces modul = unsafePerformIO $ do
|
2013-07-26 15:35:48 +00:00
|
|
|
env <- Env.initialEnvironment
|
|
|
|
(datatypes modul ++ concatMap iAdts (Map.elems interfaces))
|
|
|
|
(aliases modul ++ concatMap iAliases (Map.elems interfaces))
|
2013-07-17 17:29:27 +00:00
|
|
|
ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
|
2013-07-23 13:32:08 +00:00
|
|
|
do (_, vars, args, result) <- Env.freshDataScheme env name
|
|
|
|
return (name, (vars, foldr (T.==>) result args))
|
2013-07-17 17:29:27 +00:00
|
|
|
|
2013-08-26 03:23:49 +00:00
|
|
|
attemptConstraint <- runErrorT $ do
|
|
|
|
importedVars <-
|
|
|
|
forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
|
|
|
|
(,) name `fmap` Env.instantiateType env tipe Map.empty
|
|
|
|
|
|
|
|
let allTypes = ctors ++ importedVars
|
|
|
|
vars = concatMap (fst . snd) allTypes
|
|
|
|
header = Map.map snd (Map.fromList allTypes)
|
|
|
|
environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
|
|
|
|
|
|
|
|
fvar <- liftIO $ T.var T.Flexible
|
|
|
|
c <- TcExpr.constrain env (program modul) (T.VarN fvar)
|
|
|
|
return (header, environ c)
|
|
|
|
|
|
|
|
case attemptConstraint of
|
|
|
|
Left err -> return $ Left err
|
|
|
|
Right (header, constraint) -> do
|
|
|
|
state <- execStateT (Solve.solve constraint) TS.initialState
|
2013-10-28 21:29:28 +00:00
|
|
|
let rules = Alias.rules interfaces (aliases modul) (imports modul)
|
2013-08-26 03:23:49 +00:00
|
|
|
case TS.sErrors state of
|
|
|
|
errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
|
2014-01-05 09:41:40 +00:00
|
|
|
[] -> case Check.portTypes rules (program modul) of
|
|
|
|
Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
|
|
|
|
Left err -> return (Left err)
|