[commit: ghc] master: Tidy up tracing somewhat (342ebb0)
git at git.haskell.org
git at git.haskell.org
Fri Nov 28 13:25:52 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/342ebb0450633d6edbf764423586f49beb78facb/ghc
>---------------------------------------------------------------
commit 342ebb0450633d6edbf764423586f49beb78facb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Nov 28 11:29:40 2014 +0000
Tidy up tracing somewhat
This is a knock-on from the -dump-to-file changes.
(I found that -ddump-cs-trace stuff wasn't coming out!)
>---------------------------------------------------------------
342ebb0450633d6edbf764423586f49beb78facb
compiler/main/ErrUtils.lhs | 3 +
compiler/typecheck/TcRnMonad.lhs | 77 ++++++++++++----------
compiler/typecheck/TcSMonad.lhs | 6 +-
testsuite/tests/indexed-types/should_fail/Makefile | 2 +-
.../tests/indexed-types/should_fail/T8129.stdout | 1 +
5 files changed, 51 insertions(+), 38 deletions(-)
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index c20a731..12f484b 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -269,6 +269,9 @@ mkDumpDoc hdr doc
--
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
+--
+-- The DumpFlag is used only to choose the filename to use if --dump-to-file is
+-- used; it is not used to decide whether to dump the output
dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual flag hdr doc
= do let mFile = chooseDumpFile dflags flag
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 33fee4f..11a70aa 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -475,54 +475,47 @@ updTcRef = updMutVar
\begin{code}
traceTc :: String -> SDoc -> TcRn ()
-traceTc = traceTcN 1
+traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
-- | Typechecker trace
-traceTcN :: Int -> String -> SDoc -> TcRn ()
-traceTcN level herald doc
- = do dflags <- getDynFlags
- when (level <= traceLevel dflags && not opt_NoDebugOutput) $
- traceOptTcRn Opt_D_dump_tc_trace $
- hang (text herald) 2 doc
+traceTcN :: Int -> SDoc -> TcRn ()
+traceTcN level doc
+ = do { dflags <- getDynFlags
+ ; when (level <= traceLevel dflags) $
+ traceOptTcRn Opt_D_dump_tc_trace doc }
-traceRn, traceSplice :: SDoc -> TcRn ()
-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
-traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
+traceRn :: SDoc -> TcRn ()
+traceRn doc = traceOptTcRn Opt_D_dump_rn_trace doc
-
-traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
-traceOptIf flag doc
- = whenDOptM flag $ -- No RdrEnv available, so qualify everything
- do { dflags <- getDynFlags
- ; liftIO (putMsg dflags doc) }
+traceSplice :: SDoc -> TcRn ()
+traceSplice doc = traceOptTcRn Opt_D_dump_splices 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
+-- Just a wrapper for 'dumpSDoc'
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc
= do { dflags <- getDynFlags
- -- 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
- }
- }
+ ; when (dopt flag dflags) (traceTcRn flag doc)
+ }
+
+traceTcRn :: DumpFlag -> SDoc -> TcRn ()
+-- ^ Unconditionally dump some trace output
+--
+-- The DumpFlag is used only to set the output filename
+-- for --dump-to-file, not to decide whether or not to output
+-- That part is done by the caller
+traceTcRn flag doc
+ = do { real_doc <- prettyDoc doc
+ ; dflags <- getDynFlags
+ ; printer <- getPrintUnqualified dflags
+ ; liftIO $ dumpSDoc dflags printer flag "" real_doc }
where
- -- add current location if opt_PprStyle_Debug
+ -- 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 }
@@ -544,9 +537,25 @@ printForUserTcRn doc
-- | Typechecker debug
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc = unless opt_NoDebugOutput $
- traceOptTcRn Opt_D_dump_tc doc
+ traceOptTcRn Opt_D_dump_tc doc
\end{code}
+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
+available. Alas, they behave inconsistently with the other stuff;
+e.g. are unaffected by -dump-to-file.
+
+\begin{code}
+traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
+traceIf = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
+
+
+traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
+traceOptIf flag doc
+ = whenDOptM flag $ -- No RdrEnv available, so qualify everything
+ do { dflags <- getDynFlags
+ ; liftIO (putMsg dflags doc) }
+\end{code}
%************************************************************************
%* *
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 44ecc6f..4bd3393 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1096,10 +1096,10 @@ csTraceTcM :: Int -> TcM SDoc -> TcM ()
-- Constraint-solver tracing, -ddump-cs-trace
csTraceTcM trace_level mk_doc
= do { dflags <- getDynFlags
- ; when ((dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags)
- && traceLevel dflags >= trace_level) $
+ ; when ( (dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags)
+ && trace_level <= traceLevel dflags ) $
do { msg <- mk_doc
- ; TcM.debugDumpTcRn msg } }
+ ; TcM.traceTcRn Opt_D_dump_cs_trace msg } }
runTcS :: TcS a -- What to run
-> TcM (a, Bag EvBind)
diff --git a/testsuite/tests/indexed-types/should_fail/Makefile b/testsuite/tests/indexed-types/should_fail/Makefile
index e0738ac..d56889e 100644
--- a/testsuite/tests/indexed-types/should_fail/Makefile
+++ b/testsuite/tests/indexed-types/should_fail/Makefile
@@ -13,6 +13,6 @@ T8227:
# T8129 is trying to ensure that we don't get an
# an asertion failure with -ddump-tc-trace
T8129:
- -'$(TEST_HC)' $(TEST_HC_OPTS) -c -ddump-tc-trace T8129.hs 2> T8129.trace
+ -'$(TEST_HC)' $(TEST_HC_OPTS) -c -ddump-tc-trace T8129.hs 2> T8129.trace > T8129.trace
grep deduce T8129.trace
diff --git a/testsuite/tests/indexed-types/should_fail/T8129.stdout b/testsuite/tests/indexed-types/should_fail/T8129.stdout
index e8eca18..31d82e5 100644
--- a/testsuite/tests/indexed-types/should_fail/T8129.stdout
+++ b/testsuite/tests/indexed-types/should_fail/T8129.stdout
@@ -1 +1,2 @@
Could not deduce (C x0 (F x0))
+ Could not deduce (C x0 (F x0))
More information about the ghc-commits
mailing list