Commit 33c029fa authored by GregWeber's avatar GregWeber Committed by Austin Seipp

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
parent 53a4742d
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -126,6 +126,16 @@
<option>-ddump-core-pipeline</option> flags have been removed.
</para>
</listitem>
<listitem>
<para>
Many more options have learned to respect the <option>-ddump-to-file</option>.
For example you can use <option>-ddump-to-file</option> with <option>-ddump-splices</option>
to produce a <option>.dump-splices file</option>
for each file that uses Template Haskell.
This should be much easier to understand on a larger project
than having everything being dumped to stdout.
</para>
</listitem>
</itemizedlist>
</sect3>
......
Could not deduce (C x0 (F x0))
Could not deduce (C x0 (F x0))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment