X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=dbe822a222aa87bf0f5c5d76133d52da3cc71acc;hp=f0dd1f4b639bd90abff60bc4e2f29c880aa3f0f4;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=268072d6aeb40026d387278f7e3d73f749bfbd92 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index f0dd1f4..dbe822a 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -9,6 +9,8 @@ module TcRnMonad( module IOEnv ) where +#include "HsVersions.h" + import TcRnTypes -- Re-export all import IOEnv -- Re-export all @@ -40,10 +42,10 @@ import StaticFlags import FastString import Panic import Util - + import System.IO import Data.IORef -import Control.Exception +import qualified Data.Set as Set import Control.Monad \end{code} @@ -69,11 +71,14 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; - type_env_var <- newIORef emptyNameEnv ; dfuns_var <- newIORef emptyNameSet ; keep_var <- newIORef emptyNameSet ; + used_rdrnames_var <- newIORef Set.empty ; th_var <- newIORef False ; dfun_n_var <- newIORef 1 ; + type_env_var <- case hsc_type_env_var hsc_env of { + Just (_mod, te_var) -> return te_var ; + Nothing -> newIORef emptyNameEnv } ; let { maybe_rn_syntax empty_val | keep_rn_syntax = Just empty_val @@ -84,7 +89,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_src = hsc_src, tcg_rdr_env = hsc_global_rdr_env hsc_env, tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, + tcg_field_env = RecFields emptyNameEnv emptyNameSet, tcg_default = Nothing, tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, @@ -94,14 +99,16 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_th_used = th_var, tcg_exports = [], tcg_imports = emptyImportAvails, + tcg_used_rdrnames = used_rdrnames_var, tcg_dus = emptyDUs, - tcg_rn_imports = maybe_rn_syntax [], + tcg_rn_imports = [], tcg_rn_exports = maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, tcg_binds = emptyLHsBinds, - tcg_deprecs = NoDeprecs, + tcg_warns = NoWarnings, + tcg_anns = [], tcg_insts = [], tcg_fam_insts= [], tcg_rules = [], @@ -121,7 +128,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE + tcl_lie = panic "initTc:LIE", -- only valid inside getLIE + tcl_tybinds = panic "initTc:tybinds" + -- only valid inside a getTyBinds } ; } ; @@ -146,11 +155,10 @@ initTcPrintErrors -- Used from the interactive loop only :: HscEnv -> Module -> TcM r - -> IO (Maybe r) + -> IO (Messages, Maybe r) initTcPrintErrors env mod todo = do (msgs, res) <- initTc env HsSrcFile False mod todo - printErrorsAndWarnings (hsc_dflags env) msgs - return res + return (msgs, res) \end{code} %************************************************************************ @@ -322,6 +330,10 @@ newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys = do { us <- newUniqueSupply ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + +instance MonadUnique (IOEnv (Env gbl lcl)) where + getUniqueM = newUnique + getUniqueSupplyM = newUniqueSupply \end{code} @@ -357,9 +369,13 @@ traceOptTcRn flag doc = ifOptM flag $ do ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () -dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } +dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv + ; dflags <- getDOpts + ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } + +debugDumpTcRn :: SDoc -> TcRn () +debugDumpTcRn doc | opt_NoDebugOutput = return () + | otherwise = dumpTcRn doc dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -402,11 +418,6 @@ extendFixityEnv new_bit getRecFieldEnv :: TcRn RecFieldEnv getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } -extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a -extendRecFieldEnv new_bit - = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> - env {tcg_field_env = old_env `plusNameEnv` new_bit}) - getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} @@ -454,9 +465,12 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: Message -> TcRn () +addErr :: Message -> TcRn () -- Ignores the context stack addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } +failWith :: Message -> TcRn a +failWith msg = addErr msg >> failM + addLocErr :: Located e -> (e -> Message) -> TcRn () addLocErr (L loc e) fn = addErrAt loc (fn e) @@ -531,7 +545,7 @@ discardWarnings thing_inside \begin{code} -try_m :: TcRn r -> TcRn (Either Exception r) +try_m :: TcRn r -> TcRn (Either IOEnvFailure r) -- Does try_m, with a debug-trace on failure try_m thing = do { mb_r <- tryM thing ; @@ -558,7 +572,7 @@ mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -- Drop elements of the input that fail, so the result -- list can be shorter than the argument list mapAndRecoverM _ [] = return [] -mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) +mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) ; rs <- mapAndRecoverM f xs ; return (case mb_r of Left _ -> rs @@ -816,7 +830,7 @@ debugTc thing | otherwise = return () \end{code} - %************************************************************************ +%************************************************************************ %* * Type constraints (the so-called LIE) %* * @@ -874,6 +888,44 @@ setLclTypeEnv lcl_env thing_inside %************************************************************************ %* * + Meta type variable bindings +%* * +%************************************************************************ + +\begin{code} +getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds) +getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) } + +getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds) +getTcTyVarBinds thing_inside + = do { tybinds_var <- newMutVar emptyBag + ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var }) + thing_inside + ; tybinds <- readMutVar tybinds_var + ; return (res, tybinds) + } + +bindMetaTyVar :: TcTyVar -> TcType -> TcM () +bindMetaTyVar tv ty + = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv) + ; return (isFlexi details) }, ppr tv ) + ; tybinds_var <- getTcTyVarBindsVar + ; tybinds <- readMutVar tybinds_var + ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty) + } + +getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)] +getTcTyVarBindsRelation + = do { tybinds_var <- getTcTyVarBindsVar + ; tybinds <- readMutVar tybinds_var + ; return $ map freeTvs (bagToList tybinds) + } + where + freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty) +\end{code} + +%************************************************************************ +%* * Template Haskell context %* * %************************************************************************ @@ -951,9 +1003,11 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all initIfaceCheck hsc_env do_this - = do { let gbl_env = IfGblEnv { if_rec_types = Nothing } - ; initTcRnIf 'i' hsc_env gbl_env () do_this - } + = do let rec_types = case hsc_type_env_var hsc_env of + Just (mod,var) -> Just (mod, readMutVar var) + Nothing -> Nothing + gbl_env = IfGblEnv { if_rec_types = rec_types } + initTcRnIf 'i' hsc_env gbl_env () do_this initIfaceTc :: ModIface -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a