summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghci/RtClosureInspect.hs1
-rw-r--r--compiler/main/ErrUtils.lhs21
-rw-r--r--compiler/typecheck/TcRnDriver.lhs6
-rw-r--r--compiler/typecheck/TcRnMonad.lhs81
-rw-r--r--docs/users_guide/7.10.1-notes.xml10
-rw-r--r--testsuite/tests/indexed-types/should_fail/T8129.stdout1
6 files changed, 79 insertions, 41 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 }
diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml
index 0cf3f614a5..2db72b1187 100644
--- a/docs/users_guide/7.10.1-notes.xml
+++ b/docs/users_guide/7.10.1-notes.xml
@@ -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>
diff --git a/testsuite/tests/indexed-types/should_fail/T8129.stdout b/testsuite/tests/indexed-types/should_fail/T8129.stdout
index bd543d6d84..e8eca187c2 100644
--- a/testsuite/tests/indexed-types/should_fail/T8129.stdout
+++ b/testsuite/tests/indexed-types/should_fail/T8129.stdout
@@ -1,2 +1 @@
- Could not deduce (C x0 (F x0))
Could not deduce (C x0 (F x0))
View Lorry Controller Status