Some refactoring around endPass and debug dumping

I forget all the details, but I spent some time trying to
understand the current setup, and tried to simplify it a bit

3 files changed, 43 insertions, 40 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6db0f2ca8f..1ca19c10cc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -52,8 +52,6 @@ module DynFlags (
         tablesNextToCode, mkTablesNextToCode,
         SigOf(..), getSigOf,
 
-        printOutputForUser, printInfoForUser,
-
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
 
@@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ())
 defaultFlushErr :: FlushErr
 defaultFlushErr = FlushErr $ hFlush stderr
 
-printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printOutputForUser = printSevForUser SevOutput
-
-printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printInfoForUser = printSevForUser SevInfo
-
-printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printSevForUser sev dflags unqual doc
-    = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
-
 {-
 Note [Verbosity levels]
 ~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index c43064e7f1..8a4763913f 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -27,7 +27,8 @@ module ErrUtils (
         mkDumpDoc, dumpSDoc,
 
         --  * Messages during compilation
-        putMsg, putMsgWith,
+        putMsg, printInfoForUser, printOutputForUser,
+        logInfo, logOutput,
         errorMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
@@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc
 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags
-  = dumpSDoc dflags flag hdr doc
+  = dumpSDoc dflags alwaysQualify flag hdr doc
   | otherwise
   = return ()
 
@@ -254,12 +255,13 @@ mkDumpDoc hdr doc
 -- | Write out a dump.
 --      If --dump-to-file is set then this goes to a file.
 --      otherwise emit to stdout.
--- 
+--
 -- When hdr is empty, we print in a more compact format (no separators and
 -- blank lines)
-dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDoc dflags flag hdr doc
+dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
+dumpSDoc dflags print_unqual flag hdr doc
  = do let mFile = chooseDumpFile dflags flag
+          dump_style = mkDumpStyle print_unqual
       case mFile of
             Just fileName
                  -> do
@@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc
                                              $$ blankLine
                                              $$ doc
                                         return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
+                        defaultLogActionHPrintDoc dflags handle doc' dump_style
                         hClose handle
 
             -- write the dump to stdout
@@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc
               let (doc', severity)
                     | null hdr  = (doc, SevOutput)
                     | otherwise = (mkDumpDoc hdr doc, SevDump)
-              log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
+              log_action dflags dflags severity noSrcSpan dump_style doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -340,18 +342,9 @@ ifVerbose dflags val act
   | verbosity dflags >= val = act
   | otherwise               = return ()
 
-putMsg :: DynFlags -> MsgDoc -> IO ()
-putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
-
-putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
-putMsgWith dflags print_unqual msg
-  = log_action dflags dflags SevInfo noSrcSpan sty msg
-  where
-    sty = mkUserStyle print_unqual AllTheWay
-
 errorMsg :: DynFlags -> MsgDoc -> IO ()
-errorMsg dflags msg =
-    log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
+errorMsg dflags msg
+   = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
 
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
@@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
+  = ifVerbose dflags 1 $
+    logOutput dflags defaultUserStyle (text msg)
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
-  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
+  = ifVerbose dflags 2 $
+    logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
 
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
-debugTraceMsg dflags val msg
-  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
+debugTraceMsg dflags val msg = ifVerbose dflags val $
+                               logInfo dflags defaultDumpStyle msg
+
+putMsg :: DynFlags -> MsgDoc -> IO ()
+putMsg dflags msg = logInfo dflags defaultUserStyle msg
+
+printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
+printInfoForUser dflags print_unqual msg
+  = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
+
+printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
+printOutputForUser dflags print_unqual msg
+  = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
+
+logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
+logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
+
+logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
+-- Like logInfo but with SevOutput rather then SevInfo
+logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
 
 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
 prettyPrintGhcErrors dflags
     = ghandle $ \e -> case e of
                       PprPanic str doc ->
-                          pprDebugAndThen dflags panic str doc
+                          pprDebugAndThen dflags panic (text str) doc
                       PprSorry str doc ->
-                          pprDebugAndThen dflags sorry str doc
+                          pprDebugAndThen dflags sorry (text str) doc
                       PprProgramError str doc ->
-                          pprDebugAndThen dflags pgmError str doc
+                          pprDebugAndThen dflags pgmError (text str) doc
                       _ ->
                           liftIO $ throwIO e
 \end{code}
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 02db8efec0..a975fdd5ac 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env
                   tcg_fam_insts = fam_insts
                 }
   = do  { let dflags = hsc_dflags hsc_env
-        ; showPass dflags CoreTidy
+        ; showPassIO dflags CoreTidy
 
         ; let { insts'      = map (tidyClsInstDFun globaliseAndTidyId) insts
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
@@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces.
 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
 tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_exports   = exports
+                              , mg_rdr_env   = rdr_env
                               , mg_tcs       = tcs
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
@@ -319,8 +320,9 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
   = do  { let { dflags     = hsc_dflags hsc_env
               ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
+              ; print_unqual = mkPrintUnqualified dflags rdr_env
               }
-        ; showPass dflags CoreTidy
+        ; showPassIO dflags CoreTidy
 
         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
@@ -378,7 +380,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
 
-        ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules
+        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
 
           -- If the endPass didn't print the rules, but ddump-rules is
           -- on, print now