X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=11036f4cceaaae354cdf8e0e1b929b800c1ea613;hp=e2cbc226f7a5497e077610ad1dbf29a17b122685;hb=d7b36bbbcd56ee14656223d02e32f5a1f52ea17b;hpb=0560e796f1d813582e066a5f2bec2684c71df44d diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index e2cbc22..11036f4 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -9,8 +9,6 @@ module TcRnMonad( module IOEnv ) where -#include "HsVersions.h" - import TcRnTypes -- Re-export all import IOEnv -- Re-export all @@ -36,14 +34,16 @@ import Bag import Outputable import UniqSupply import Unique +import LazyUniqFM import DynFlags import StaticFlags import FastString import Panic - +import Util + import System.IO import Data.IORef -import Control.Exception +import Control.Monad \end{code} @@ -55,11 +55,6 @@ import Control.Exception %************************************************************************ \begin{code} -ioToTcRn :: IO r -> TcRn r -ioToTcRn = ioToIOEnv -\end{code} - -\begin{code} initTc :: HscEnv -> HscSource @@ -73,23 +68,26 @@ 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 | otherwise = Nothing ; gbl_env = TcGblEnv { - tcg_mod = mod, - tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, - tcg_fix_env = emptyNameEnv, - tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_mod = mod, + tcg_src = hsc_src, + tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = Nothing, + tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, @@ -104,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 = [], @@ -112,11 +110,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc = Nothing, - tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing + tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing, + tcg_hpc = False } ; lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = mkGeneralSrcSpan FSLIT("Top level"), + tcl_loc = mkGeneralSrcSpan (fsLit "Top level"), tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, @@ -129,7 +128,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - addBreakpointBindings $ do { r <- tryM do_this ; case r of Right res -> return (Just res) @@ -149,17 +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 -\end{code} - -\begin{code} -addBreakpointBindings :: TcM a -> TcM a -addBreakpointBindings thing_inside - = thing_inside + return (msgs, res) \end{code} %************************************************************************ @@ -182,7 +173,7 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside ; let { env = Env { env_top = hsc_env, env_us = us_var, env_gbl = gbl_env, - env_lcl = lcl_env } } + env_lcl = lcl_env} } ; runIOEnv env thing_inside } @@ -243,7 +234,8 @@ unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) -ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true +-- | Do it flag is true +ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } @@ -324,12 +316,16 @@ newUniqueSupply newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) } + ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } 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,20 +336,20 @@ 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 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything traceOptIf flag doc = ifOptM flag $ - ioToIOEnv (printForUser stderr alwaysQualify doc) + liftIO (printForUser stderr alwaysQualify doc) traceOptTcRn :: DynFlag -> SDoc -> TcRn () traceOptTcRn flag doc = ifOptM flag $ do @@ -366,7 +362,12 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } + 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) @@ -392,6 +393,9 @@ tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } @@ -403,6 +407,9 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} @@ -450,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) @@ -461,15 +471,16 @@ addErrAt loc msg = addLongErrAt loc msg empty addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () addLongErrAt loc msg extra - = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } addErrs :: [(SrcSpan,Message)] -> TcRn () -addErrs msgs = mappM_ add msgs +addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg @@ -480,26 +491,27 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; + dflags <- getDOpts ; + let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext SLIT("Warning:") <+> msg) +addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg) +addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) addLocWarn :: Located e -> (e -> Message) -> TcRn () addLocWarn (L loc e) fn = addReportAt loc (fn e) checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False -checkErr ok msg = checkM ok (addErr msg) +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) @@ -525,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) @@ -543,8 +555,21 @@ 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 - Right res -> returnM res } + Left _ -> recover + Right res -> return res } + + +----------------------- +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 <- try_m (f x) + ; rs <- mapAndRecoverM f xs + ; return (case mb_r of + Left _ -> rs + Right r -> r:rs) } + ----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) @@ -558,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 @@ -618,7 +643,7 @@ checkNoErrs main = do { (msgs, mb_res) <- tryTcLIE main ; addMessages msgs ; case mb_res of - Nothing -> failM + Nothing -> failM Just val -> return val } @@ -656,7 +681,7 @@ setErrCtxt :: ErrCtxt -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) addErrCtxt :: Message -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) @@ -672,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 @@ -683,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. @@ -696,7 +721,7 @@ addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } addErrsTc :: [Message] -> TcM () -addErrsTc err_msgs = mappM_ addErrTc err_msgs +addErrsTc err_msgs = mapM_ addErrTc err_msgs addErrTcM :: (TidyEnv, Message) -> TcM () addErrTcM (tidy_env, err_msg) @@ -717,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 = returnM () +checkTc True _ = return () checkTc False err = failWithTc err \end{code} @@ -732,7 +757,7 @@ addWarnTcM :: (TidyEnv, Message) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; ctxt_msgs <- do_ctxt env0 ctxt ; - addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) } + addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) } warnTc :: Bool -> Message -> TcM () warnTc warn_if_true warn_msg @@ -768,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} @@ -787,11 +817,9 @@ debugTc is useful for monadic debugging code \begin{code} debugTc :: TcM () -> TcM () -#ifdef DEBUG -debugTc thing = thing -#else -debugTc thing = return () -#endif +debugTc thing + | debugIsOn = thing + | otherwise = return () \end{code} %************************************************************************ @@ -831,7 +859,7 @@ extendLIE inst extendLIEs :: [Inst] -> TcM () extendLIEs [] - = returnM () + = return () extendLIEs insts = do { lie_var <- getLIEVar ; lie <- readMutVar lie_var ; @@ -860,9 +888,11 @@ setLclTypeEnv lcl_env thing_inside recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } -keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set -keepAliveTc n = do { env <- getGblEnv; - ; updMutVar (tcg_keep env) (`addOneToNameSet` n) } +keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set +keepAliveTc id + | isLocalId id = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) } + | otherwise = return () keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set keepAliveSetTc ns = do { env <- getGblEnv; @@ -902,8 +932,8 @@ setLocalRdrEnv rdr_env thing_inside mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_tv_env = emptyUFM, + if_id_env = emptyUFM } initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside @@ -916,7 +946,7 @@ initIfaceExtCore :: IfL a -> TcRn a initIfaceExtCore thing_inside = do { tcg_env <- getGblEnv ; let { mod = tcg_mod tcg_env - ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod) + ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod) ; if_env = IfGblEnv { if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } ; if_lenv = mkIfLclEnv mod doc @@ -927,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 @@ -944,7 +976,7 @@ initIfaceTc iface do_this } where mod = mi_module iface - doc = ptext SLIT("The interface for") <+> quotes (ppr mod) + doc = ptext (sLit "The interface for") <+> quotes (ppr mod) initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore @@ -974,7 +1006,7 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs (full_msg defaultErrStyle)) ; failM } -------------------- @@ -1009,7 +1041,7 @@ forkM_maybe doc thing_inside ; return Nothing } }} where - print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside @@ -1019,5 +1051,3 @@ forkM doc thing_inside -- pprPanic "forkM" doc Just r -> r) } \end{code} - -