X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=eedf00bd4c864ac6f29649daaded4c19d6d3be9b;hp=a7c930d33f233969f028882d4d0639a230da0b2a;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=1919ebdb449fc458987528ad4686357c15e23f1b diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a7c930d..eedf00b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -3,13 +3,6 @@ % \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, @@ -28,7 +21,6 @@ import TcType import InstEnv import FamInstEnv -import Coercion import Var import Id import VarSet @@ -48,10 +40,9 @@ import StaticFlags import FastString import Panic import Util - + import System.IO import Data.IORef -import Control.Exception import Control.Monad \end{code} @@ -77,11 +68,13 @@ 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 ; 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 +85,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, @@ -109,7 +102,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_rn_decls = maybe_rn_syntax emptyRnGroup, tcg_binds = emptyLHsBinds, - tcg_deprecs = NoDeprecs, + tcg_warns = NoWarnings, tcg_insts = [], tcg_fam_insts= [], tcg_rules = [], @@ -154,11 +147,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 +322,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 +336,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 @@ -367,7 +363,11 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; dflags <- getDOpts ; - liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } + 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 +410,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 +457,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 +511,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 +537,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 +555,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 +563,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 +583,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 +697,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 +708,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 +742,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 +793,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} @@ -954,9 +957,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