X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=ff1979bc06444f1b0b377bcd8b188fa3ddbbae86;hb=31751ccacc24ebe5d15a0af84b10dc612d455440;hp=47cd4020a6f74853de9ac7f418cf5175c25eac51;hpb=7c3d4a1f2b2529ce300b8acc1d26ad98312b9e96;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 47cd402..ff1979b 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -10,39 +10,53 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all -import HsSyn ( MonoBinds(..) ) +#if defined(GHCI) && defined(BREAKPOINT) +import TypeRep ( Type(..), liftedTypeKind, TyThing(..) ) +import Var ( mkTyVar, mkGlobalId ) +import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) +import OccName ( mkOccName, tvName ) +import SrcLoc ( noSrcLoc ) +import TysWiredIn ( intTy, stringTy, mkListTy, unitTy ) +import PrelNames ( breakpointJumpName ) +import NameEnv ( mkNameEnv ) +#endif + +import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, Dependencies(..), TypeEnv, emptyTypeEnv, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), + isHsBoot, ModSummary(..), ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), - Deprecs(..), FixityEnv, FixItem, - GhciMode, lookupType, unQualInScope ) -import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv ) + Deprecs(..), FixityEnv, FixItem, + lookupType, unQualInScope ) +import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName ) +import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) import Type ( Type ) -import NameEnv ( extendNameEnvList ) -import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) +import TcType ( tcIsTyVarTy, tcGetTyVar ) +import NameEnv ( extendNameEnvList, nameEnvElts ) +import InstEnv ( emptyInstEnv ) +import Var ( setTyVarName ) import VarSet ( emptyVarSet ) -import VarEnv ( TidyEnv, emptyTidyEnv ) +import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings ) -import SrcLoc ( SrcLoc, mkGeneralSrcLoc ) + mkWarnMsg, printErrorsAndWarnings, + mkLocMessage, mkLongErrMsg ) +import Packages ( mkHomeModules ) +import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) -import NameSet ( emptyDUs, emptyNameSet ) -import OccName ( emptyOccEnv ) -import Module ( moduleName ) +import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) +import OccName ( emptyOccEnv, tidyOccName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) import Unique ( Unique ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) +import StaticFlags ( opt_PprStyle_Debug ) import Bag ( snocBag, unionBags ) import Panic ( showException ) -import Maybe ( isJust ) import IO ( stderr ) import DATA_IOREF ( newIORef, readIORef ) import EXCEPTION ( Exception ) @@ -63,45 +77,55 @@ ioToTcRn = ioToIOEnv \begin{code} initTc :: HscEnv + -> HscSource -> Module -> TcM r - -> IO (Maybe r) + -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env mod do_this +initTc hsc_env hsc_src 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 ; let { gbl_env = TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_default = Nothing, tcg_type_env = emptyNameEnv, tcg_type_env_var = type_env_var, - tcg_inst_env = mkImpInstEnv hsc_env, + tcg_inst_env = emptyInstEnv, tcg_inst_uses = dfuns_var, - tcg_exports = [], + tcg_th_used = th_var, + tcg_exports = emptyNameSet, tcg_imports = init_imports, + tcg_home_mods = home_mods, tcg_dus = emptyDUs, - tcg_binds = EmptyMonoBinds, + tcg_rn_imports = Nothing, + tcg_rn_exports = Nothing, + tcg_rn_decls = Nothing, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], tcg_fords = [], - tcg_keep = emptyNameSet + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = mkGeneralSrcLoc FSLIT("Top level of module"), + tcl_loc = mkGeneralSrcSpan FSLIT("Top level"), tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, - tcl_arrow_ctxt = topArrowCtxt, + tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE @@ -110,37 +134,66 @@ initTc hsc_env mod do_this -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } ; - - -- Print any error messages + do { +#if defined(GHCI) && defined(BREAKPOINT) + unique <- newUnique ; + let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; + tyvar = mkTyVar var liftedTypeKind; + breakpointJumpType = mkGlobalId + (VanillaGlobal) + (breakpointJumpName) + (FunTy intTy + (FunTy (mkListTy unitTy) + (FunTy stringTy + (ForAllTy tyvar + (FunTy (TyVarTy tyvar) + (TyVarTy tyvar)))))) + (vanillaIdInfo); + new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))]; + }; + r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this) +#else + r <- tryM do_this +#endif + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } ; + + -- Collect any error messages msgs <- readIORef errs_var ; - printErrorsAndWarnings msgs ; let { dflags = hsc_dflags hsc_env ; final_res | errorsFound dflags msgs = Nothing | otherwise = maybe_res } ; - return final_res + return (msgs, final_res) } where - init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } + home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) + -- A guess at the home modules. This will be correct in + -- --make and GHCi modes, but in one-shot mode we need to + -- fix it up after we know the real dependencies of the current + -- module (see tcRnModule). + -- Setting it here is necessary for the typechecker entry points + -- other than tcRnModule: tcRnGetInfo, for example. These are + -- all called via the GHC module, so hsc_mod_graph will contain + -- something sensible. + + init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat -- "unknown module M". -mkImpInstEnv :: HscEnv -> InstEnv --- At the moment we (wrongly) build an instance environment from all the --- home-package modules we have already compiled. --- We should really only get instances from modules below us in the --- module import tree. -mkImpInstEnv (HscEnv {hsc_dflags = dflags, hsc_HPT = hpt}) - = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt - where - add dfuns inst_env = foldl extendInstEnv inst_env dfuns +initTcPrintErrors -- Used from the interactive loop only + :: HscEnv + -> Module + -> TcM r + -> IO (Maybe r) +initTcPrintErrors env mod todo = do + (msgs, res) <- initTc env HsSrcFile mod todo + printErrorsAndWarnings (hsc_dflags env) msgs + return res -- mkImpTypeEnv makes the imported symbol table mkImpTypeEnv :: ExternalPackageState -> HomePackageTable @@ -226,12 +279,16 @@ getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } +setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} ) + ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRnIf gbl lcl GhciMode -getGhciMode = do { env <- getTopEnv; return (hsc_mode env) } +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } \end{code} \begin{code} @@ -241,24 +298,36 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } getEps :: TcRnIf gbl lcl ExternalPackageState getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } -setEps :: ExternalPackageState -> TcRnIf gbl lcl () -setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps } +-- Updating the EPS. This should be an atomic operation. +-- Note the delicate 'seq' which forces the EPS before putting it in the +-- variable. Otherwise what happens is that we get +-- write eps_var (....(unsafeRead eps_var)....) +-- and if the .... is strict, that's obviously bottom. By forcing it beforehand +-- we make the unsafeRead happen before we update the variable. updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) -> TcRnIf gbl lcl a -updateEps upd_fn = do { eps_var <- getEpsVar +updateEps upd_fn = do { traceIf (text "updating EPS") + ; eps_var <- getEpsVar ; eps <- readMutVar eps_var ; let { (eps', val) = upd_fn eps } - ; writeMutVar eps_var eps' + ; seq eps' (writeMutVar eps_var eps') ; return val } updateEps_ :: (ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl () -updateEps_ upd_fn = do { eps_var <- getEpsVar - ; updMutVar eps_var upd_fn } +updateEps_ upd_fn = do { traceIf (text "updating EPS_") + ; eps_var <- getEpsVar + ; eps <- readMutVar eps_var + ; let { eps' = upd_fn eps } + ; seq eps' (writeMutVar eps_var eps') } getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } \end{code} %************************************************************************ @@ -280,6 +349,11 @@ newUniqueSupply let { (us1, us2) = splitUniqSupply us } ; writeMutVar u_var us1 ; return us2 } + +newLocalName :: Name -> TcRnIf gbl lcl Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name)) \end{code} @@ -291,26 +365,35 @@ newUniqueSupply \begin{code} traceTc, traceRn :: SDoc -> TcRn () -traceRn = dumpOptTcRn Opt_D_dump_rn_trace -traceTc = dumpOptTcRn Opt_D_dump_tc_trace -traceSplice = dumpOptTcRn Opt_D_dump_splices +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 = dumpOptIf Opt_D_dump_if_trace -traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs -dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -dumpOptIf flag doc = ifOptM flag $ +traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything +traceOptIf flag doc = ifOptM flag $ ioToIOEnv (printForUser stderr alwaysQualify doc) -dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) +traceOptTcRn :: DynFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = ifOptM flag $ do + { ctxt <- getErrCtxt + ; loc <- getSrcSpanM + ; env0 <- tcInitTidyEnv + ; ctxt_msgs <- do_ctxt env0 ctxt + ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs)) + ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + +dumpOptTcRn :: DynFlag -> SDoc -> TcRn () +dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) \end{code} @@ -324,6 +407,12 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } +setModule :: Module -> TcRn a -> TcRn a +setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside + +tcIsHsBoot :: TcRn Bool +tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } + getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } @@ -349,12 +438,32 @@ getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } %************************************************************************ \begin{code} -getSrcLocM :: TcRn SrcLoc +getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcLocM = do { env <- getLclEnv; return (tcl_loc env) } - -addSrcLoc :: SrcLoc -> TcRn a -> TcRn a -addSrcLoc loc = updLclEnv (\env -> env { tcl_loc = loc }) +getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } + +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan loc thing_inside + | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside + | otherwise = thing_inside -- Don't overwrite useful info with useless + +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a + +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) \end{code} @@ -366,30 +475,48 @@ setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: Message -> TcRn () -addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg } +addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } + +addLocErr :: Located e -> (e -> Message) -> TcRn () +addLocErr (L loc e) fn = addErrAt loc (fn e) -addErrAt :: SrcLoc -> Message -> TcRn () -addErrAt loc msg - = do { errs_var <- getErrsVar ; +addErrAt :: SrcSpan -> Message -> TcRn () +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))) ; + errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ; + let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } -addErrs :: [(SrcLoc,Message)] -> TcRn () +addErrs :: [(SrcSpan,Message)] -> TcRn () addErrs msgs = mappM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn () -addWarn msg +addReport :: Message -> TcRn () +addReport msg = do loc <- getSrcSpanM; addReportAt loc msg + +addReportAt :: SrcSpan -> Message -> TcRn () +addReportAt loc msg = do { errs_var <- getErrsVar ; - loc <- getSrcLocM ; rdr_env <- getGlobalRdrEnv ; - let { warn = addShortWarnLocLine loc (unQualInScope rdr_env) msg } ; + let { warn = mkWarnMsg loc (unQualInScope 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) + +addWarnAt :: SrcSpan -> Message -> TcRn () +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) @@ -422,68 +549,88 @@ discardWarnings thing_inside \begin{code} +try_m :: TcRn r -> TcRn (Either Exception 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 } + where + exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) + +----------------------- recoverM :: TcRn r -- Recovery action; do this if the main one fails -> TcRn r -- Main action: do this first -> TcRn r +-- Errors in 'thing' are retained recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } +----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) - -- (tryTc m) executes m, and returns - -- Just r, if m succeeds (returning r) and caused no errors - -- Nothing, if m fails, or caused errors - -- It also returns all the errors accumulated by m - -- (even in the Just case, there might be warnings) - -- - -- It always succeeds (never raises an exception) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) tryTc m = do { errs_var <- newMutVar emptyMessages ; - - mb_r <- try_m (setErrsVar errs_var m) ; - - new_errs <- readMutVar errs_var ; - - dflags <- getDOpts ; - - return (new_errs, - case mb_r of - Left exn -> Nothing - Right r | errorsFound dflags new_errs -> Nothing - | otherwise -> Just r) + res <- try_m (setErrsVar errs_var m) ; + msgs <- readMutVar errs_var ; + return (msgs, case res of + Left exn -> Nothing + Right val -> Just val) + -- The exception is always the IOEnv built-in + -- in exception; see IOEnv.failM } -try_m :: TcRn r -> TcRn (Either Exception 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 } - where - exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) +----------------------- +tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) +-- Run the thing, returning +-- Just r, if m succceeds with no error messages +-- Nothing, if m fails, or if it succeeds but has error messages +-- Either way, the messages are returned; even in the Just case +-- there might be warnings +tryTcErrs thing + = do { (msgs, res) <- tryTc thing + ; dflags <- getDOpts + ; let errs_found = errorsFound dflags msgs + ; return (msgs, case res of + Nothing -> Nothing + Just val | errs_found -> Nothing + | otherwise -> Just val) + } +----------------------- tryTcLIE :: TcM a -> TcM (Messages, Maybe a) --- Just like tryTc, except that it ensures that the LIE +-- Just like tryTcErrs, except that it ensures that the LIE -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ; - ifM (isJust mb_r) (extendLIEs lie) ; - return (errs, mb_r) } + = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ; + ; case mb_res of + Nothing -> return (msgs, Nothing) + Just val -> do { extendLIEs lie; return (msgs, Just val) } + } +----------------------- tryTcLIE_ :: TcM r -> TcM r -> TcM r --- (tryTcLIE_ r m) tries m; if it succeeds it returns it, --- otherwise it returns r. Any error messages added by m are discarded, --- whether or not m succeeds. +-- (tryTcLIE_ r m) tries m; +-- if m succeeds with no error messages, it's the answer +-- otherwise tryTcLIE_ drops everything from m and tries r instead. tryTcLIE_ recover main - = do { (_msgs, mb_res) <- tryTcLIE main ; - case mb_res of - Just res -> return res - Nothing -> recover } + = do { (msgs, mb_res) <- tryTcLIE main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } +----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors -- If m fails then (checkNoErrsTc m) fails. @@ -492,12 +639,12 @@ checkNoErrs :: TcM r -> TcM r -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. checkNoErrs main - = do { (msgs, mb_res) <- tryTcLIE main ; - addMessages msgs ; - case mb_res of - Just r -> return r - Nothing -> failM - } + = do { (msgs, mb_res) <- tryTcLIE main + ; addMessages msgs + ; case mb_res of + Nothing -> failM + Just val -> return val + } ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out main @@ -526,35 +673,41 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ \begin{code} -setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a -setErrCtxtM msg = updCtxt (\ msgs -> [msg]) -addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) +getErrCtxt :: TcM ErrCtxt +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } -setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a -setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg)) -addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +setErrCtxt :: ErrCtxt -> TcM a -> TcM a +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) +addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) -getErrCtxt :: TcM ErrCtxt -getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) } +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) -- Helper function for the above updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) +-- Conditionally add an error context +maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a +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 }) + getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin - = do { loc <- getSrcLocM ; env <- getLclEnv ; + = do { loc <- getSrcSpanM ; env <- getLclEnv ; return (InstLoc origin loc (tcl_ctxt env)) } addInstCtxt :: InstLoc -> TcM a -> TcM a --- Add the SrcLoc and context from the first Inst in the list +-- Add the SrcSpan and context from the first Inst in the list -- (they all have similar locations) addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) + = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) \end{code} The addErrTc functions add an error message, but do not cause failure. @@ -563,7 +716,8 @@ addInstCtxt (InstLoc _ src_loc ctxt) thing_inside \begin{code} addErrTc :: Message -> TcM () -addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg) +addErrTc err_msg = do { env0 <- tcInitTidyEnv + ; addErrTcM (env0, err_msg) } addErrsTc :: [Message] -> TcM () addErrsTc err_msgs = mappM_ addErrTc err_msgs @@ -571,7 +725,7 @@ addErrsTc err_msgs = mappM_ addErrTc err_msgs addErrTcM :: (TidyEnv, Message) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; - loc <- getSrcLocM ; + loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } \end{code} @@ -597,7 +751,8 @@ checkTc False err = failWithTc err addWarnTc :: Message -> TcM () addWarnTc msg = do { ctxt <- getErrCtxt ; - ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ; + env0 <- tcInitTidyEnv ; + ctxt_msgs <- do_ctxt env0 ctxt ; addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) } warnTc :: Bool -> Message -> TcM () @@ -606,12 +761,37 @@ warnTc warn_if_true warn_msg | otherwise = return () \end{code} - Helper functions +----------------------------------- + Tidying + +We initialise the "tidy-env", used for tidying types before printing, +by building a reverse map from the in-scope type variables to the +OccName that the programmer originally used for them + +\begin{code} +tcInitTidyEnv :: TcM TidyEnv +tcInitTidyEnv + = do { lcl_env <- getLclEnv + ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty) + | ATyVar name ty <- nameEnvElts (tcl_env lcl_env) + , tcIsTyVarTy ty ] + ; return (foldl add emptyTidyEnv nm_tv_prs) } + where + add (env,subst) (name, tyvar) + = case tidyOccName env (nameOccName name) of + (env', occ') -> (env', extendVarEnv subst tyvar tyvar') + where + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' +\end{code} + +----------------------------------- + Other helper functions \begin{code} add_err_tcm tidy_env err_msg loc ctxt = do { ctxt_msgs <- do_ctxt tidy_env ctxt ; - addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) } + addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) } do_ctxt tidy_env [] = return [] @@ -624,13 +804,31 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt | otherwise = take 3 ctxt \end{code} -%************************************************************************ +debugTc is useful for monadic debugging code + +\begin{code} +debugTc :: TcM () -> TcM () +#ifdef DEBUG +debugTc thing = thing +#else +debugTc thing = return () +#endif +\end{code} + + %************************************************************************ %* * Type constraints (the so-called LIE) %* * %************************************************************************ \begin{code} +nextDFunIndex :: TcM Int -- Get the next dfun index +nextDFunIndex = do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; n <- readMutVar dfun_n_var + ; writeMutVar dfun_n_var (n+1) + ; return n } + getLIEVar :: TcM (TcRef LIE) getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } @@ -680,6 +878,17 @@ setLclTypeEnv lcl_env thing_inside %************************************************************************ \begin{code} +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) } + +keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set +keepAliveSetTc ns = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`unionNameSets` ns) } + getStage :: TcM ThStage getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } @@ -690,32 +899,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ %* * - Arrow context -%* * -%************************************************************************ - -\begin{code} -popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes -popArrowBinders - = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) }) - where - pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned}) - = ASSERT( not (curr_lvl `elem` banned) ) - ArrCtxt {proc_level = curr_lvl, proc_banned = curr_lvl : banned} - -getBannedProcLevels :: TcM [ProcLevel] - = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } - -incProcLevel :: TcM a -> TcM a -incProcLevel - = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) }) - where - inc ctxt = ctxt { proc_level = proc_level ctxt + 1 } -\end{code} - - -%************************************************************************ -%* * Stuff for the renamer's local env %* * %************************************************************************ @@ -737,12 +920,16 @@ setLocalRdrEnv rdr_env thing_inside %************************************************************************ \begin{code} +mkIfLclEnv :: Module -> SDoc -> IfLclEnv +mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, + if_loc = loc, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } + initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv - ; let { if_env = IfGblEnv { - if_rec_types = Just (tcg_mod tcg_env, get_type_env), - if_is_boot = imp_dep_mods (tcg_imports tcg_env) } + ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) } ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -750,12 +937,10 @@ 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) ; if_env = IfGblEnv { - if_rec_types = Just (mod, return (tcg_type_env tcg_env)), - if_is_boot = imp_dep_mods (tcg_imports tcg_env) } - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } + ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (if_env, if_lenv) thing_inside } @@ -763,54 +948,55 @@ 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_is_boot = emptyModuleEnv, - if_rec_types = Nothing } ; - } + = do { let gbl_env = IfGblEnv { if_rec_types = Nothing } ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceTc :: HscEnv -> ModIface - -> (TcRef TypeEnv -> IfL a) -> IO a +initIfaceTc :: ModIface + -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a -- Used when type-checking checking an up-to-date interface file -- No type envt from the current module, but we do know the module dependencies -initIfaceTc hsc_env iface do_this - = do { tc_env_var <- newIORef emptyTypeEnv - ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)), - if_rec_types = Just (mod, readMutVar tc_env_var) } ; - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } +initIfaceTc iface do_this + = do { tc_env_var <- newMutVar emptyTypeEnv + ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; + ; if_lenv = mkIfLclEnv mod doc } - ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) + ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) } where mod = mi_module iface + doc = ptext SLIT("The interface for") <+> quotes (ppr mod) initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore -- We have available the type envt of the module being compiled, and we must use it initIfaceRules hsc_env guts do_this = do { let { - is_boot = mkModDeps (dep_mods (mg_deps guts)) - -- Urgh! But we do somehow need to get the info - -- on whether (for this particular compilation) we should - -- import a hi-boot file or not. - ; type_info = (mg_module guts, return (mg_types guts)) - ; gbl_env = IfGblEnv { if_is_boot = is_boot, - if_rec_types = Just type_info } ; + type_info = (mg_module guts, return (mg_types guts)) + ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ; } -- Run the thing; any exceptions just bubble out from here ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a -initIfaceLcl mod thing_inside - = setLclEnv (IfLclEnv { if_mod = mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv }) - thing_inside +initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } +-------------------- +failIfM :: Message -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldnt happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg + ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) + ; failM } -------------------- forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) @@ -848,6 +1034,9 @@ forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside = do { mb_res <- forkM_maybe doc thing_inside ; return (case mb_res of - Nothing -> pprPanic "forkM" doc + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc Just r -> r) } \end{code} + +