diff options
-rw-r--r-- | compiler/GHC/Iface/Load.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Backpack.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 7 |
4 files changed, 14 insertions, 9 deletions
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 89a8ee6e20..f510e9bbda 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -415,7 +415,8 @@ loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from = do dflags <- getDynFlags - withException dflags (loadInterface doc mod_name where_from) + let ctx = initSDocContext dflags defaultUserStyle + withException ctx (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index fc53b91d68..59c31ad566 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -1173,11 +1173,12 @@ getOrphanHashes hsc_env mods = do hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle get_orph_hash mod = case lookupIfaceByModule hpt pit mod of Just iface -> return (mi_orphan_hash (mi_final_exts iface)) Nothing -> do -- similar to 'mkHashFun' - iface <- initIfaceLoad hsc_env . withException dflags + iface <- initIfaceLoad hsc_env . withException ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem return (mi_orphan_hash (mi_final_exts iface)) @@ -1470,6 +1471,7 @@ mkHashFun hsc_env eps name dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle occ = nameOccName name orig_mod = nameModule name lookup mod = do @@ -1481,7 +1483,7 @@ mkHashFun hsc_env eps name -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack. - initIfaceLoad hsc_env . withException dflags + initIfaceLoad hsc_env . withException ctx $ withoutDynamicNow -- For some unknown reason, we need to reset the -- dynamicNow bit, otherwise only dynamic diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index d433a46aed..9c1d3a3991 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -21,6 +21,7 @@ import GHC.Prelude import GHC.Driver.Env import GHC.Driver.Ppr +import GHC.Driver.Session import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity) @@ -283,11 +284,12 @@ findExtraSigImports' :: HscEnv findExtraSigImports' hsc_env HsigFile modname = fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> (initIfaceLoad hsc_env - . withException dflags + . withException ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle unit_state = hsc_units hsc_env reqs = requirementMerges unit_state modname @@ -598,8 +600,9 @@ mergeSignatures ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do let m = mkModule (VirtUnit iuid) mod_name im = fst (getModuleInstantiation m) + ctx = initSDocContext dflags defaultUserStyle fmap fst - . withException dflags + . withException ctx $ findAndReadIface logger nc fc hooks unit_state home_unit dflags (text "mergeSignatures") im m NotBoot diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index dea37f4919..0572ab00db 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -174,7 +174,6 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Driver.Env -import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Runtime.Context @@ -600,11 +599,11 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error. -withException :: MonadIO m => DynFlags -> m (MaybeErr SDoc a) -> m a -withException dflags do_this = do +withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a +withException ctx do_this = do r <- do_this case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) Succeeded result -> return result {- |