Make withException use SDocContext instead of DynFlags

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
 
 {-