X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=dbe822a222aa87bf0f5c5d76133d52da3cc71acc;hp=a7c930d33f233969f028882d4d0639a230da0b2a;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=1919ebdb449fc458987528ad4686357c15e23f1b diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a7c930d..dbe822a 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -3,19 +3,14 @@ % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcRnMonad( module TcRnMonad, module TcRnTypes, module IOEnv ) where +#include "HsVersions.h" + import TcRnTypes -- Re-export all import IOEnv -- Re-export all @@ -28,7 +23,6 @@ import TcType import InstEnv import FamInstEnv -import Coercion import Var import Id import VarSet @@ -48,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} @@ -77,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 @@ -92,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, @@ -102,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 = [], @@ -129,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 } ; } ; @@ -154,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} %************************************************************************ @@ -330,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} @@ -340,13 +344,13 @@ newSysLocalIds fs tys %************************************************************************ \begin{code} -traceTc, traceRn :: SDoc -> TcRn () +traceTc, traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace traceTc = traceOptTcRn Opt_D_dump_tc_trace traceSplice = traceOptTcRn Opt_D_dump_splices -traceIf :: SDoc -> TcRnIf m n () +traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@ -365,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) @@ -410,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} @@ -462,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) @@ -513,7 +519,7 @@ checkErr ok msg = unless ok (addErr msg) warnIf :: Bool -> Message -> TcRn () warnIf True msg = addWarn msg -warnIf False msg = return () +warnIf False _ = return () addMessages :: Messages -> TcRn () addMessages (m_warns, m_errs) @@ -539,13 +545,13 @@ 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 ; case mb_r of Left exn -> do { traceTc (exn_msg exn); return mb_r } - Right r -> return mb_r } + Right _ -> return mb_r } where exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) @@ -557,7 +563,7 @@ recoverM :: TcRn r -- Recovery action; do this if the main one fails recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of - Left exn -> recover + Left _ -> recover Right res -> return res } @@ -565,8 +571,8 @@ recoverM recover thing 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 f [] = return [] -mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) +mapAndRecoverM _ [] = return [] +mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) ; rs <- mapAndRecoverM f xs ; return (case mb_r of Left _ -> rs @@ -585,7 +591,7 @@ tryTc m res <- try_m (setErrsVar errs_var m) ; msgs <- readMutVar errs_var ; return (msgs, case res of - Left exn -> Nothing + Left _ -> Nothing Right val -> Just val) -- The exception is always the IOEnv built-in -- in exception; see IOEnv.failM @@ -699,7 +705,7 @@ maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside maybeAddErrCtxt Nothing thing_inside = thing_inside popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) +popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin @@ -710,7 +716,7 @@ addInstCtxt :: InstLoc -> TcM a -> TcM a -- Add the SrcSpan and context from the first Inst in the list -- (they all have similar locations) addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) + = setSrcSpan src_loc (updCtxt (\_ -> ctxt) thing_inside) \end{code} The addErrTc functions add an error message, but do not cause failure. @@ -744,7 +750,7 @@ failWithTcM local_and_msg = addErrTcM local_and_msg >> failM checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true -checkTc True err = return () +checkTc True _ = return () checkTc False err = failWithTc err \end{code} @@ -795,17 +801,22 @@ tcInitTidyEnv Other helper functions \begin{code} +add_err_tcm :: TidyEnv -> Message -> SrcSpan + -> [TidyEnv -> TcM (TidyEnv, SDoc)] + -> TcM () add_err_tcm tidy_env err_msg loc ctxt = do { ctxt_msgs <- do_ctxt tidy_env ctxt ; addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) } -do_ctxt tidy_env [] +do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc] +do_ctxt _ [] = return [] do_ctxt tidy_env (c:cs) = do { (tidy_env', m) <- c tidy_env ; ms <- do_ctxt tidy_env' cs ; return (m:ms) } +ctxt_to_use :: [SDoc] -> [SDoc] ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt | otherwise = take 3 ctxt \end{code} @@ -819,7 +830,7 @@ debugTc thing | otherwise = return () \end{code} - %************************************************************************ +%************************************************************************ %* * Type constraints (the so-called LIE) %* * @@ -877,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 %* * %************************************************************************ @@ -954,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