make TcRnMonad.lhs respect -ddump-to-file

Summary: allows things such as: -ddump-to-file -ddump-splices

Test Plan:
compile with flags -ddump-to-file -ddump-splices
verify that it does output an extra file

Try out other flags.
I noticed that with -ddump-tc there is some output going to file and some to stdout.

Reviewers: hvr, austin

Reviewed By: austin

Subscribers: simonpj, thomie, carter

Differential Revision: https://phabricator.haskell.org/D460

GHC Trac Issues: #9126

4 files changed, 69 insertions, 40 deletions

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 1f751d1d23..953f9b5cb6 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -573,6 +573,7 @@ runTR_maybe hsc_env thing_inside
                                 thing_inside
        ; return res }
 
+-- | Term Reconstruction trace
 traceTR :: SDoc -> TR ()
 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 8a4763913f..c20a731442 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -23,7 +23,7 @@ module ErrUtils (
 
         ghcExit,
         doIfSet, doIfSet_dyn,
-        dumpIfSet, dumpIfSet_dyn,
+        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
         mkDumpDoc, dumpSDoc,
 
         --  * Messages during compilation
@@ -235,12 +235,23 @@ dumpIfSet dflags flag hdr doc
   | not flag   = return ()
   | otherwise  = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
+-- | a wrapper around 'dumpSDoc'.
+-- First check whether the dump flag is set
+-- Do nothing if it is unset
 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
-  | dopt flag dflags
-  = dumpSDoc dflags alwaysQualify flag hdr doc
-  | otherwise
-  = return ()
+  = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
+
+-- | a wrapper around 'dumpSDoc'.
+-- First check whether the dump flag is set
+-- Do nothing if it is unset
+--
+-- Unlike 'dumpIfSet_dyn',
+-- has a printer argument but no header argument
+dumpIfSet_dyn_printer :: PrintUnqualified
+                      -> DynFlags -> DumpFlag -> SDoc -> IO ()
+dumpIfSet_dyn_printer printer dflags flag doc
+  = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
 
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 893e0290da..32113bb976 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1471,7 +1471,7 @@ tcRnStmt hsc_env rdr_stmt
 
 -------------------------------------------------- -}
 
-    dumpOptTcRn Opt_D_dump_tc
+    traceOptTcRn Opt_D_dump_tc
         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
                text "Typechecked expr" <+> ppr zonked_expr]) ;
 
@@ -1994,7 +1994,7 @@ loadUnqualIfaces hsc_env ictxt
 \begin{code}
 rnDump :: SDoc -> TcRn ()
 -- Dump, with a banner, if -ddump-rn
-rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
+rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
 
 tcDump :: TcGblEnv -> TcRn ()
 tcDump env
@@ -2005,7 +2005,7 @@ tcDump env
              (printForUserTcRn short_dump) ;
 
         -- Dump bindings if -ddump-tc
-        dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
+        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
    }
   where
     short_dump = pprTcGblEnv env
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 1088c84d04..41f861c02c 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -471,15 +471,17 @@ updTcRef = updMutVar
 traceTc :: String -> SDoc -> TcRn ()
 traceTc = traceTcN 1
 
+-- | Typechecker trace
 traceTcN :: Int -> String -> SDoc -> TcRn ()
 traceTcN level herald doc
     = do dflags <- getDynFlags
-         when (level <= traceLevel dflags) $
-             traceOptTcRn Opt_D_dump_tc_trace $ hang (text herald) 2 doc
+         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
+             traceOptTcRn Opt_D_dump_tc_trace $
+                 hang (text herald) 2 doc
 
 traceRn, traceSplice :: SDoc -> TcRn ()
-traceRn      = traceOptTcRn Opt_D_dump_rn_trace
-traceSplice  = traceOptTcRn Opt_D_dump_splices
+traceRn      = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
+traceSplice  = traceOptTcRn Opt_D_dump_splices  -- Template Haskell
 
 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
@@ -492,36 +494,51 @@ traceOptIf flag doc
     do { dflags <- getDynFlags
        ; liftIO (putMsg dflags doc) }
 
+-- | Output a doc if the given 'DumpFlag' is set.
+--
+-- By default this logs to stdout
+-- However, if the `-ddump-to-file` flag is set,
+-- then this will dump output to a file
+
+-- just a wrapper for 'dumpIfSet_dyn_printer'
+--
+-- does not check opt_NoDebugOutput;
+-- caller is responsible for than when appropriate
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
--- Output the message, with current location if opt_PprStyle_Debug
-traceOptTcRn flag doc 
-  = whenDOptM flag $
-    do { loc  <- getSrcSpanM
-       ; let real_doc
-               | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
-               | otherwise = doc   -- The full location is
-                                   -- usually way too much
-       ; dumpTcRn real_doc }
-
-dumpTcRn :: SDoc -> TcRn ()
-dumpTcRn doc
+traceOptTcRn flag doc
   = do { dflags <- getDynFlags
-       ; rdr_env <- getGlobalRdrEnv
-       ; liftIO (logInfo dflags (mkDumpStyle (mkPrintUnqualified dflags rdr_env)) doc) }
+       -- Checking the dynamic flag here is redundant when the flag is set
+       -- But it avoids extra work when the flag is unset.
+       ; when (dopt flag dflags) $ do {
+           ; real_doc <- prettyDoc doc
+           ; printer <- getPrintUnqualified dflags
+           ; liftIO $ dumpIfSet_dyn_printer printer dflags flag real_doc
+           }
+       }
+  where
+    -- add current location if opt_PprStyle_Debug
+    prettyDoc :: SDoc -> TcRn SDoc
+    prettyDoc doc = if opt_PprStyle_Debug
+       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
+       else return doc -- The full location is usually way too much
+
 
+getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
+getPrintUnqualified dflags
+  = do { rdr_env <- getGlobalRdrEnv
+       ; return $ mkPrintUnqualified dflags rdr_env }
+
+-- | Like logInfoTcRn, but for user consumption
 printForUserTcRn :: SDoc -> TcRn ()
--- Like dumpTcRn, but for user consumption
 printForUserTcRn doc
   = do { dflags <- getDynFlags
-       ; rdr_env <- getGlobalRdrEnv
-       ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
+       ; printer <- getPrintUnqualified dflags
+       ; liftIO (printInfoForUser dflags printer doc) }
 
+-- | Typechecker debug
 debugDumpTcRn :: SDoc -> TcRn ()
-debugDumpTcRn doc | opt_NoDebugOutput = return ()
-                  | otherwise         = dumpTcRn doc
-
-dumpOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc)
+debugDumpTcRn doc = unless opt_NoDebugOutput $
+  traceOptTcRn Opt_D_dump_tc doc
 \end{code}
 
 
@@ -684,9 +701,9 @@ discardWarnings thing_inside
 \begin{code}
 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
 mkLongErrAt loc msg extra
-  = do { rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDynFlags ;
-         return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         return $ mkLongErrMsg dflags loc printer msg extra }
 
 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
@@ -987,9 +1004,9 @@ add_warn msg extra_info
 
 add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 add_warn_at loc msg extra_info
-  = do { rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDynFlags ;
-         let { warn = mkLongWarnMsg dflags loc (mkPrintUnqualified dflags rdr_env)
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         let { warn = mkLongWarnMsg dflags loc printer
                                     msg extra_info } ;
          reportWarning warn }