Replace printDump with a new Severity

We now use log_action with severity SevDump, rather than calling
printDump. This means that what happens to dumped info is now under
the control of the GHC API user, rather than always going to stdout.

14 files changed, 54 insertions, 36 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index ec7adf543f..ca5ef9ac88 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -109,7 +109,9 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
      hashNo <- writeMixEntries dflags mod count entries orig_file2
      modBreaks <- mkModBreaks count entries
 
-     doIfSet_dyn dflags Opt_D_dump_ticked $ printDump (pprLHsBinds binds1)
+     doIfSet_dyn dflags Opt_D_dump_ticked $
+         log_action dflags SevDump noSrcSpan defaultDumpStyle
+             (pprLHsBinds binds1)
    
      return (binds1, HpcInfo count hashNo, modBreaks)
 
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index f91ee14de7..ca7d53891e 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -231,10 +231,11 @@ filterNameMap mods env
 
 
 -- | Display the persistent linker state.
-showLinkerState :: IO ()
-showLinkerState
+showLinkerState :: DynFlags -> IO ()
+showLinkerState dflags
   = do pls <- readIORef v_PersistentLinkerState >>= readMVar
-       printDump (vcat [text "----- Linker state -----",
+       log_action dflags SevDump noSrcSpan defaultDumpStyle
+                 (vcat [text "----- Linker state -----",
                         text "Pkgs:" <+> ppr (pkgs_loaded pls),
                         text "Objs:" <+> ppr (objs_loaded pls),
                         text "BCOs:" <+> ppr (bcos_loaded pls)])
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index aef9a325f9..9445808b13 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -49,6 +49,7 @@ import Maybes
 import ErrUtils
 import Finder
 import UniqFM
+import SrcLoc
 import StaticFlags
 import Outputable
 import BinIface
@@ -643,7 +644,8 @@ showIface hsc_env filename = do
    -- non-profiled interfaces, for example.
    iface <- initTcRnIf 's' hsc_env () () $
        readBinIface IgnoreHiWay TraceBinIFaceReading filename
-   printDump (pprModIface iface)
+   let dflags = hsc_dflags hsc_env
+   log_action dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
 \end{code}
 
 \begin{code}
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 88ba0b5741..c869ded308 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -23,10 +23,11 @@ import DynFlags
 import Config
 import SysTools
 
-import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
+import ErrUtils
 import Outputable
 import Module
 import Maybes           ( firstJusts )
+import SrcLoc
 
 import Control.Exception
 import Control.Monad
@@ -56,7 +57,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
                 { showPass dflags "CmmLint"
                 ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
                 ; case firstJusts lints of
-                        Just err -> do { printDump err
+                        Just err -> do { log_action dflags SevDump noSrcSpan defaultDumpStyle err
                                        ; ghcExit dflags 1
                                        }
                         Nothing  -> return ()
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1f72f8e396..aa646ec847 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -969,6 +969,7 @@ defaultLogAction :: LogAction
 defaultLogAction severity srcSpan style msg
     = case severity of
       SevOutput -> printSDoc msg style
+      SevDump   -> hPrintDump stdout msg
       SevInfo   -> printErrs msg style
       SevFatal  -> printErrs msg style
       _         -> do hPutChar stderr '\n'
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index dc73257967..5eaaa8d5bc 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -71,6 +71,7 @@ type MsgDoc = SDoc
 
 data Severity
   = SevOutput
+  | SevDump
   | SevInfo
   | SevWarning
   | SevError
@@ -193,10 +194,10 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 -- -----------------------------------------------------------------------------
 -- Dumping
 
-dumpIfSet :: Bool -> String -> SDoc -> IO ()
-dumpIfSet flag hdr doc
+dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
+dumpIfSet dflags flag hdr doc
   | not flag   = return ()
-  | otherwise  = printDump (mkDumpDoc hdr doc)
+  | otherwise  = log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
@@ -247,7 +248,7 @@ dumpSDoc dflags dflag hdr doc
 
             -- write the dump to stdout
             Nothing
-                 -> printDump (mkDumpDoc hdr doc)
+                 -> log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags
diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot
index 7718cbe2a6..6f4a373313 100644
--- a/compiler/main/ErrUtils.lhs-boot
+++ b/compiler/main/ErrUtils.lhs-boot
@@ -6,6 +6,7 @@ import SrcLoc (SrcSpan)
 
 data Severity
   = SevOutput
+  | SevDump
   | SevInfo
   | SevWarning
   | SevError
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 4a54c89545..8d190d4e5e 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1706,7 +1706,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
 dumpIfaceStats :: HscEnv -> IO ()
 dumpIfaceStats hsc_env = do
     eps <- readIORef (hsc_EPS hsc_env)
-    dumpIfSet (dump_if_trace || dump_rn_stats)
+    dumpIfSet dflags (dump_if_trace || dump_rn_stats)
               "Interface statistics"
               (ifaceStats eps)
   where
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 15f68d3dcd..215d6c9fac 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -51,8 +51,10 @@ import Packages( isDllName )
 import HscTypes
 import Maybes
 import UniqSupply
+import ErrUtils (Severity(..))
 import Outputable
 import FastBool hiding ( fastOr )
+import SrcLoc
 import Util
 import FastString
 
@@ -372,7 +374,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
           -- If the endPass didn't print the rules, but ddump-rules is
           -- on, print now
-	; dumpIfSet (dopt Opt_D_dump_rules dflags 
+	; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
                      && (not (dopt Opt_D_dump_simpl dflags))) 
 		    CoreTidy
                     (ptext (sLit "rules"))
@@ -381,7 +383,8 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
           -- Print one-line size info
         ; let cs = coreBindsStats tidy_binds
         ; when (dopt Opt_D_dump_core_stats dflags)
-	       (printDump (ptext (sLit "Tidy size (terms,types,coercions)") 
+               (log_action dflags SevDump noSrcSpan defaultDumpStyle
+                          (ptext (sLit "Tidy size (terms,types,coercions)")
                            <+> ppr (moduleName mod) <> colon 
                            <+> int (cs_tm cs) 
                            <+> int (cs_ty cs) 
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index c3a3dce9c7..edc5a65ed9 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -91,6 +91,7 @@ import FastString
 import qualified ErrUtils as Err
 import Bag
 import Maybes
+import SrcLoc
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
 import MonadUtils
@@ -145,9 +146,9 @@ endPass dflags pass binds rules
                            | dopt Opt_D_verbose_core2core dflags -> Just dflag
                 _ -> Nothing
 
-dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
-dumpIfSet dump_me pass extra_info doc
-  = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
+dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dflags dump_me pass extra_info doc
+  = Err.dumpIfSet dflags dump_me (showSDoc (ppr pass <+> extra_info)) doc
 
 dumpPassResult :: DynFlags 
                -> Maybe DynFlag		-- Just df => show details in a file whose
@@ -189,10 +190,11 @@ displayLintResults :: DynFlags -> CoreToDo
                    -> IO ()
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
-  = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
-			 , ptext (sLit "*** Offending Program ***")
-			 , pprCoreBindings binds
-			 , ptext (sLit "*** End of Offense ***") ])
+  = do { log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+           (vcat [ banner "errors", Err.pprMessageBag errs
+                 , ptext (sLit "*** Offending Program ***")
+                 , pprCoreBindings binds
+                 , ptext (sLit "*** End of Offense ***") ])
        ; Err.ghcExit dflags 1 }
 
   | not (isEmptyBag warns)
@@ -203,7 +205,8 @@ displayLintResults dflags pass warns errs binds
 	-- group.  Only afer a round of simplification are they unravelled.
   , not opt_NoDebugOutput
   , showLintWarnings pass
-  = printDump (banner "warnings" $$ Err.pprMessageBag warns)
+  = log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+        (banner "warnings" $$ Err.pprMessageBag warns)
 
   | otherwise = return ()
   where
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 0ebde64d6f..a90fc0ca68 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -47,6 +47,7 @@ import DmdAnal          ( dmdAnalPgm )
 import WorkWrap         ( wwTopBinds )
 import Vectorise        ( vectorise )
 import FastString
+import SrcLoc
 import Util
 
 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
@@ -419,15 +420,17 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass)
 %************************************************************************
 
 \begin{code}
-printCore :: a -> CoreProgram -> IO ()
-printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
+printCore :: DynFlags -> CoreProgram -> IO ()
+printCore dflags binds
+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
 
 ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
 ruleCheckPass current_phase pat guts = do
     rb <- getRuleBase
     dflags <- getDynFlags
     liftIO $ Err.showPass dflags "RuleCheck"
-    liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
+    liftIO $ log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+                 (ruleCheckProgram current_phase pat rb (mg_binds guts))
     return guts
 
 
@@ -492,8 +495,8 @@ simplifyExpr dflags expr
               (expr', counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
 				 simplExprGently (simplEnvForGHCi dflags) expr
 
-	; Err.dumpIfSet (dopt Opt_D_dump_simpl_stats dflags)
-		  "Simplifier statistics" (pprSimplCount counts)
+        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
+                  "Simplifier statistics" (pprSimplCount counts)
 
 	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 			(pprCoreExpr expr')
@@ -555,7 +558,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
   = do { (termination_msg, it_count, counts_out, guts')
            <- do_iteration us 1 [] binds rules
 
-        ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+        ; Err.dumpIfSet dflags (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
                   "Simplifier statistics for following pass"
                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
                          blankLine,
diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs
index 8ade2d5f10..1bec3925ac 100644
--- a/compiler/simplStg/SimplStg.lhs
+++ b/compiler/simplStg/SimplStg.lhs
@@ -27,7 +27,8 @@ import DynFlags		( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
 			  getStgToDo )
 import Id		( Id )
 import Module		( Module )
-import ErrUtils		( doIfSet_dyn, dumpIfSet_dyn, showPass )
+import ErrUtils
+import SrcLoc
 import UniqSupply	( mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 \end{code}
@@ -44,7 +45,7 @@ stg2stg dflags module_name binds
 	; us <- mkSplitUniqSupply 'g'
 
 	; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
-		      (printDump (text "VERBOSE STG-TO-STG:"))
+		      (log_action dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
 
 	; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
 
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index c8188d798b..3130f7175f 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -39,7 +39,7 @@ module Outputable (
         colBinder, bold, keyword,
 
         -- * Converting 'SDoc' into strings and outputing it
-        hPrintDump, printDump,
+        hPrintDump,
         printForC, printForAsm, printForUser, printForUserPartWay,
         pprCode, mkCodeStyle,
         showSDoc, showSDocOneLine,
@@ -88,7 +88,7 @@ import qualified Data.IntMap as IM
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word
-import System.IO        ( Handle, stdout, hFlush )
+import System.IO        ( Handle, hFlush )
 import System.FilePath
 
 
@@ -318,9 +318,6 @@ ifPprDebug d = SDoc $ \ctx ->
 \end{code}
 
 \begin{code}
-printDump :: SDoc -> IO ()
-printDump doc = hPrintDump stdout doc
-
 hPrintDump :: Handle -> SDoc -> IO ()
 hPrintDump h doc = do
    Pretty.printDoc PageMode h
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index f29fa06f2b..8c1f5ec5ce 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -2078,7 +2078,9 @@ showCmd str = do
         ["imports"]  -> showImports
         ["modules" ] -> showModules
         ["bindings"] -> showBindings
-        ["linker"]   -> liftIO showLinkerState
+        ["linker"]   ->
+            do dflags <- getDynFlags
+               liftIO $ showLinkerState dflags
         ["breaks"]   -> showBkptTable
         ["context"]  -> showContext
         ["packages"]  -> showPackages