diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-11-28 11:29:40 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-11-28 11:30:02 +0000 |
commit | 342ebb0450633d6edbf764423586f49beb78facb (patch) | |
tree | 5198ff909e3d9998bee23029dffa7e57db349c16 | |
parent | 227a566851f19f5a720c4a86fdb1ff99117325c6 (diff) | |
download | haskell-342ebb0450633d6edbf764423586f49beb78facb.tar.gz |
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!)
-rw-r--r-- | compiler/main/ErrUtils.lhs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 77 | ||||
-rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 6 | ||||
-rw-r--r-- | testsuite/tests/indexed-types/should_fail/Makefile | 2 | ||||
-rw-r--r-- | testsuite/tests/indexed-types/should_fail/T8129.stdout | 3 |
5 files changed, 52 insertions, 39 deletions
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index c20a731442..12f484b421 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 33fee4f2d3..11a70aa76b 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 +traceRn :: SDoc -> TcRn () +traceRn doc = traceOptTcRn Opt_D_dump_rn_trace doc -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) } +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 44ecc6f090..4bd3393103 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 e0738ac138..d56889e566 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 e8eca187c2..31d82e59fa 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)) + Could not deduce (C x0 (F x0)) |