From 603fae70c0c60da424d2e83b6da878d55dac068d Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 31 Oct 2022 11:26:11 -1000 Subject: [PATCH] dev: lib: clean up/simplify debug helpers --- .../Reports/AccountTransactionsReport.hs | 8 +- hledger-lib/Hledger/Utils/Debug.hs | 296 ++++++++---------- hledger-lib/Hledger/Utils/Parse.hs | 2 +- hledger-ui/Hledger/UI/UIUtils.hs | 2 +- hledger/Hledger/Cli/CliOptions.hs | 1 + 5 files changed, 145 insertions(+), 164 deletions(-) diff --git a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs index 891554122..91fe784c1 100644 --- a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs @@ -121,16 +121,16 @@ accountTransactionsReport rspec@ReportSpec{_rsReportOpts=ropts} j thisacctq = it -- want to keep prices around, so we can toggle between cost and no cost quickly. We can use -- the show_costs_ flag to be efficient when we can, and detailed when we have to. (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripPrices) - . ptraceAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns) + . traceAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns) -- maybe convert these transactions to cost or value . journalApplyValuationFromOpts rspec - . ptraceAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns) + . traceAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns) -- apply any cur:SYM filters in reportq . (if queryIsNull amtq then id else filterJournalAmounts amtq) -- only consider transactions which match thisacctq (possibly excluding postings -- which are not real or have the wrong status) . traceAt 3 ("thisacctq: "++show thisacctq) - $ ptraceAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns) + $ traceAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns) j{jtxns = filter (matchesTransaction thisacctq . relevantPostings) $ jtxns j} where relevantPostings @@ -155,7 +155,7 @@ accountTransactionsReport rspec@ReportSpec{_rsReportOpts=ropts} j thisacctq = it items = accountTransactionsReportItems reportq thisacctq startbal maNegate (journalAccountType j) -- sort by the transaction's register date, then index, for accurate starting balance - . ptraceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd) + . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd) . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd)) . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t)) $ jtxns acctJournal diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index f4b2aaee0..ac2ca877b 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -1,26 +1,25 @@ {- | -Helpers for debug logging to console or file. -This module also exports Debug.Trace and (from the breakpoint package) Debug.Breakpoint. -Uses Hledger.Utils.Print. See also additional helpers in Hledger.Utils.Parse, -Hledger.UI.UIUtils etc. +Convenient helpers for debug logging to stderr or a file. +The function names try to balance consistency, memorability, and ease of typing. +This module also exports Debug.Trace and the breakpoint package's Debug.Breakpoint. -@dbg0@-@dbg9@ will pretty-print values to stderr -if the program was run with a sufficiently high @--debug=N@ argument. -(@--debug@ with no argument means @--debug=1@; @dbg0@ always prints). +The @dbgN*@ functions are intended to be added at points of interest in your code. +They will print labelled values to stderr, only if the program was run with a +sufficiently high debug level. Debug level ranges from 0 (no output) to 9 (most output), +and is set by the @--debug[=N]@ command line option. (@--debug@ with no argument means 1). -Uses unsafePerformIO for simple program-wide read-only access to the debug level -set by the --debug command-line flag. The @debugLevel@ global is set once at startup, -so in GHCI if you want to change it you must save this file and :reload. -(Sometimes it's more convenient to temporarily add dbg0's in your code and :reload.) +The command line is parsed for --debug using unsafePerformIO, for easy use of these helpers +in existing code, or before normal command line parsing. +If you are working in GHCI, changing the debug level requires editing and reloading this file. +Sometimes it's more convenient to temporarily add dbg0's in your code and :reload. -Debug level is a number from 1 (least output) to 9 (most output). In hledger, debug levels are used as follows: Debug level: What to show: ------------ --------------------------------------------------------- 0 normal command output only (no warnings, eg) -1 (--debug) useful warnings, most common troubleshooting info, eg valuation +1 useful warnings, most common troubleshooting info, eg valuation 2 common troubleshooting info, more detail 3 report options selection 4 report generation @@ -40,17 +39,22 @@ Debug level: What to show: -- https://hackage.haskell.org/package/debug module Hledger.Utils.Debug ( - -- * Tracing - traceWith - -- * Pretty tracing - ,ptrace - -- ** Debug-level-aware tracing - ,debugLevel + -- * Tracing to stderr + debugLevel + ,traceWith ,traceAt ,traceAtWith + ,ptrace ,ptraceAt - ,ptraceAtWith - -- ** Easiest form (recommended) + ,ptraceAtIO + -- * Logging to a file + -- ,debugLogLevel + ,traceLog + ,traceLogAt + -- ,ptraceLogAt + -- ,ptraceLogAtWith + -- ,ptraceLogAtIO + -- * Convenient pretty tracing in pure code ,dbg0 ,dbg1 ,dbg2 @@ -62,7 +66,7 @@ module Hledger.Utils.Debug ( ,dbg8 ,dbg9 ,dbgExit - -- ** More control + -- * Convenient tracing with a show function ,dbg0With ,dbg1With ,dbg2With @@ -73,8 +77,7 @@ module Hledger.Utils.Debug ( ,dbg7With ,dbg8With ,dbg9With - -- ** For standalone lines in IO blocks - ,ptraceAtIO + -- * Convenient pretty tracing in IO ,dbg0IO ,dbg1IO ,dbg2IO @@ -85,62 +88,45 @@ module Hledger.Utils.Debug ( ,dbg7IO ,dbg8IO ,dbg9IO - -- ** Debug-logging to a file - ,dlogTrace - ,dlogTraceAt - ,dlogAt - ,dlog0 - ,dlog1 - ,dlog2 - ,dlog3 - ,dlog4 - ,dlog5 - ,dlog6 - ,dlog7 - ,dlog8 - ,dlog9 - -- ** Re-exports + -- * Re-exports ,module Debug.Breakpoint ,module Debug.Trace ) where import Control.DeepSeq (force) -import Control.Monad.IO.Class +import Control.Exception (evaluate) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List hiding (uncons) import Debug.Breakpoint -import Debug.Trace +import Debug.Trace (trace) import Safe (readDef) import System.Environment (getArgs) -import System.Exit +import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (evaluate) --- import Hledger.Utils.Parse -import Hledger.Utils.Print --- import Text.Megaparsec (MonadParsec) +import Hledger.Utils.Print (pshow) -- XXX some of the below can be improved with pretty-simple, https://github.com/cdepillabout/pretty-simple#readme --- | Pretty trace. Easier alias for traceShowId + pShow. -ptrace :: Show a => a -> a -ptrace = traceWith pshow - --- | Like traceShowId, but uses a custom show function to render the value. --- traceShowIdWith was too much of a mouthful. +-- | Trace a showable value with the given show function before returning it. traceWith :: Show a => (a -> String) -> a -> a traceWith f a = trace (f a) a --- | Global debug level, which controls the verbosity of debug errput --- on the console. The default is 0 meaning no debug errput. The --- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to +-- | Pretty-trace a showable value before returning it. +-- Like Debug.Trace.traceShowId, but pretty-printing and easier to type. +ptrace :: Show a => a -> a +ptrace = traceWith pshow + +-- | Global debug output level. This is the requested verbosity of +-- debug output printed to stderr. The default is 0 meaning no debug output. +-- The @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to -- a higher value (note: not @--debug N@ for some reason). This uses -- unsafePerformIO and can be accessed from anywhere and before normal -- command-line processing. When running with :main in GHCI, you must -- touch and reload this module to see the effect of a new --debug option. -- {-# OPTIONS_GHC -fno-cse #-} {-# NOINLINE debugLevel #-} --- Avoid using dbg* in this function (infinite loop). debugLevel :: Int debugLevel = case dropWhile (/="--debug") args of ["--debug"] -> 1 @@ -149,7 +135,6 @@ debugLevel = case dropWhile (/="--debug") args of case take 1 $ filter ("--debug" `isPrefixOf`) args of ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v _ -> 0 - where args = unsafePerformIO getArgs @@ -180,25 +165,94 @@ ptraceAt level | otherwise = ls in trace (s++":"++nlorspace++intercalate "\n" ls') a --- | Like ptraceAt, but takes a custom show function instead of a label. -ptraceAtWith :: Show a => Int -> (a -> String) -> a -> a -ptraceAtWith level f - | level > 0 && debugLevel < level = id - | otherwise = \a -> let p = f a - -- ls = lines p - -- nlorspace | length ls > 1 = "\n" - -- | otherwise = " " ++ take (10 - length s) (repeat ' ') - -- ls' | length ls > 1 = map (" "++) ls - -- | otherwise = ls - -- in trace (s++":"++nlorspace++intercalate "\n" ls') a - in trace p a +-- | Like ptraceAt, but convenient to insert in an IO monad and +-- enforces monadic sequencing. +-- XXX These have a bug; they should use +-- traceIO, not trace, otherwise GHC can occasionally over-optimise +-- (cf lpaste a few days ago where it killed/blocked a child thread). +ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () +ptraceAtIO lvl lbl x = liftIO $ ptraceAt lvl lbl x `seq` return () --- "dbg" would clash with megaparsec. --- | Pretty-print a label and the showable value to the console, then return it. +-- XXX separate file logging debug level and helpers - probably not needed +-- since you can just redirect stderr to a file, on unix at least. + +-- -- | Global debug log level. Like debugLevel, but controls verbosity +-- -- of debug output logged to the debug log file. +-- -- {-# OPTIONS_GHC -fno-cse #-} +-- {-# NOINLINE debugLogLevel #-} +-- debugLogLevel :: Int +-- debugLogLevel = case dropWhile (/="--debug") args of +-- ["--debug-log"] -> 1 +-- "--debug-log":n:_ -> readDef 1 n +-- _ -> +-- case take 1 $ filter ("--debug-log" `isPrefixOf`) args of +-- ['-':'-':'d':'e':'b':'u':'g':'-':'l':'o':'g':'=':v] -> readDef 1 v +-- _ -> 0 +-- where +-- args = unsafePerformIO getArgs + +-- | Log a string to ./debug.log before returning the second argument. +-- Uses unsafePerformIO. +-- {-# NOINLINE traceLog #-} +traceLog :: String -> a -> a +traceLog s x = unsafePerformIO $ do + evaluate (force s) -- to complete any previous logging before we attempt more + appendFile "debug.log" (s ++ "\n") + return x + +-- | Log a string to ./debug.log before returning the second argument, +-- if the global debug level is at or above the specified level. +-- At level 0, always logs. Otherwise, uses unsafePerformIO. +traceLogAt :: Int -> String -> a -> a +traceLogAt level s + | level > 0 && debugLevel < level = id + | otherwise = traceLog s + +-- -- | Pretty-log a label and showable value to ./debug.log, +-- -- if the global debug level is at or above the specified level. +-- -- At level 0, always prints. Otherwise, uses unsafePerformIO. +-- ptraceLogAt :: Show a => Int -> String -> a -> a +-- ptraceLogAt level +-- | level > 0 && debugLogLevel < level = const id +-- | otherwise = \lbl a -> +-- let +-- ls = lines $ pshow' a +-- nlorspace | length ls > 1 = "\n" +-- | otherwise = replicate (max 1 $ 11 - length lbl) ' ' +-- ls' | length ls > 1 = map (' ':) ls +-- | otherwise = ls +-- in traceLog (lbl++":"++nlorspace++intercalate "\n" ls') a + +-- -- | Like ptraceLogAt, but takes a custom show function instead of a label. +-- ptraceLogAtWith :: Show a => Int -> (a -> String) -> a -> a +-- ptraceLogAtWith level f +-- | level > 0 && debugLevel < level = id +-- | otherwise = \a -> let p = f a +-- -- ls = lines p +-- -- nlorspace | length ls > 1 = "\n" +-- -- | otherwise = " " ++ take (10 - length s) (repeat ' ') +-- -- ls' | length ls > 1 = map (" "++) ls +-- -- | otherwise = ls +-- -- in trace (s++":"++nlorspace++intercalate "\n" ls') a +-- in trace p a + +-- -- | Like ptraceAt, but convenient to insert in an IO monad and +-- -- enforces monadic sequencing. +-- -- XXX These have a bug; they should use +-- -- traceIO, not trace, otherwise GHC can occasionally over-optimise +-- -- (cf lpaste a few days ago where it killed/blocked a child thread). +-- ptraceLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () +-- ptraceLogAtIO lvl lbl x = liftIO $ ptraceLogAt lvl lbl x `seq` return () + +-- | Pretty-trace and pretty-log a label and showable value +-- to stderr and the debug log, then return it. dbg0 :: Show a => String -> a -> a dbg0 = ptraceAt 0 --- | Pretty-print a label and the showable value to the console when the global debug level is >= 1, then return it. +-- | Pretty-trace a label and showable value to stderr if +-- --debug level is high enough, +-- and pretty-log to the debug log if --debug-log level is +-- high enough, then return the value. -- Uses unsafePerformIO. dbg1 :: Show a => String -> a -> a dbg1 = ptraceAt 1 @@ -232,49 +286,38 @@ dbg9 = ptraceAt 9 dbgExit :: Show a => String -> a -> a dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg --- | Like dbg0, but takes a custom show function instead of a label. +-- | Like dbgN, but taking a show function instead of a label. dbg0With :: Show a => (a -> String) -> a -> a -dbg0With = ptraceAtWith 0 +dbg0With = traceAtWith 0 dbg1With :: Show a => (a -> String) -> a -> a -dbg1With = ptraceAtWith 1 +dbg1With = traceAtWith 1 dbg2With :: Show a => (a -> String) -> a -> a -dbg2With = ptraceAtWith 2 +dbg2With = traceAtWith 2 dbg3With :: Show a => (a -> String) -> a -> a -dbg3With = ptraceAtWith 3 +dbg3With = traceAtWith 3 dbg4With :: Show a => (a -> String) -> a -> a -dbg4With = ptraceAtWith 4 +dbg4With = traceAtWith 4 dbg5With :: Show a => (a -> String) -> a -> a -dbg5With = ptraceAtWith 5 +dbg5With = traceAtWith 5 dbg6With :: Show a => (a -> String) -> a -> a -dbg6With = ptraceAtWith 6 +dbg6With = traceAtWith 6 dbg7With :: Show a => (a -> String) -> a -> a -dbg7With = ptraceAtWith 7 +dbg7With = traceAtWith 7 dbg8With :: Show a => (a -> String) -> a -> a -dbg8With = ptraceAtWith 8 +dbg8With = traceAtWith 8 dbg9With :: Show a => (a -> String) -> a -> a -dbg9With = ptraceAtWith 9 - --- | Like ptraceAt, but convenient to insert in an IO monad and --- enforces monadic sequencing (plus convenience aliases). --- XXX These have a bug; they should use --- traceIO, not trace, otherwise GHC can occasionally over-optimise --- (cf lpaste a few days ago where it killed/blocked a child thread). -ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () -ptraceAtIO lvl lbl x = liftIO $ ptraceAt lvl lbl x `seq` return () - --- XXX Could not deduce (a ~ ()) --- ptraceAtM :: (Monad m, Show a) => Int -> String -> a -> m a --- ptraceAtM lvl lbl x = ptraceAt lvl lbl x `seq` return x +dbg9With = traceAtWith 9 +-- | Like dbgN, but convenient to use in IO. dbg0IO :: (MonadIO m, Show a) => String -> a -> m () dbg0IO = ptraceAtIO 0 @@ -305,66 +348,3 @@ dbg8IO = ptraceAtIO 8 dbg9IO :: (MonadIO m, Show a) => String -> a -> m () dbg9IO = ptraceAtIO 9 --- | Log a string to ./debug.log before returning the second argument. --- Uses unsafePerformIO. --- {-# NOINLINE dlogTrace #-} -dlogTrace :: String -> a -> a -dlogTrace s x = unsafePerformIO $ do - evaluate (force s) -- to complete any previous logging before we attempt more - appendFile "debug.log" (s ++ "\n") - return x - --- | Log a string to ./debug.log before returning the second argument, --- if the global debug level is at or above the specified level. --- At level 0, always logs. Otherwise, uses unsafePerformIO. -dlogTraceAt :: Int -> String -> a -> a -dlogTraceAt level s - | level > 0 && debugLevel < level = id - | otherwise = dlogTrace s - --- | Log and pretty-print a label and showable value to "./debug.log", --- if the global debug level is at or above the specified level. --- At level 0, always prints. Otherwise, uses unsafePerformIO. -dlogAt :: Show a => Int -> String -> a -> a -dlogAt level - | level > 0 && debugLevel < level = const id - | otherwise = \lbl a -> - let - ls = lines $ pshow' a - nlorspace | length ls > 1 = "\n" - | otherwise = replicate (max 1 $ 11 - length lbl) ' ' - ls' | length ls > 1 = map (' ':) ls - | otherwise = ls - in dlogTrace (lbl++":"++nlorspace++intercalate "\n" ls') a - --- | Pretty-print a label and the showable value to ./debug.log if at or above --- a certain debug level, then return it. -dlog0 :: Show a => String -> a -> a -dlog0 = dlogAt 0 - -dlog1 :: Show a => String -> a -> a -dlog1 = dlogAt 1 - -dlog2 :: Show a => String -> a -> a -dlog2 = dlogAt 2 - -dlog3 :: Show a => String -> a -> a -dlog3 = dlogAt 3 - -dlog4 :: Show a => String -> a -> a -dlog4 = dlogAt 4 - -dlog5 :: Show a => String -> a -> a -dlog5 = dlogAt 5 - -dlog6 :: Show a => String -> a -> a -dlog6 = dlogAt 6 - -dlog7 :: Show a => String -> a -> a -dlog7 = dlogAt 7 - -dlog8 :: Show a => String -> a -> a -dlog8 = dlogAt 8 - -dlog9 :: Show a => String -> a -> a -dlog9 = dlogAt 9 diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs index 23be863d6..f91f8af45 100644 --- a/hledger-lib/Hledger/Utils/Parse.hs +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -75,7 +75,7 @@ type TextParser m a = ParsecT HledgerParseErrorData Text m a -- | Print the provided label (if non-null) and current parser state -- (position and next input) to the console. See also megaparsec's dbg. --- traceParse :: String -> TextParser m () +traceParse :: String -> TextParser m () traceParse msg = do pos <- getSourcePos next <- (T.take peeklength) `fmap` getInput diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs index e75c4481d..acf663fe7 100644 --- a/hledger-ui/Hledger/UI/UIUtils.hs +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -443,7 +443,7 @@ listScrollPushingSelection name listheight scrollamt = do -- if the global debug level is at or above a standard hledger-ui debug level. -- Uses unsafePerformIO. dlogUiTrace :: String -> a -> a -dlogUiTrace = dlogTraceAt uiDebugLevel +dlogUiTrace = traceLogAt uiDebugLevel -- | Like dlogUiTrace, but convenient in IO. dlogUiTraceIO :: String -> IO () diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index e9abd52d2..8337c0020 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -556,6 +556,7 @@ getHledgerCliOpts' mode' args0 = do ," See also hledger -h for general hledger options." ] -- | Print debug info about arguments and options if --debug is present. + -- XXX use standard dbg helpers debugArgs :: [String] -> CliOpts -> IO () debugArgs args1 opts = when ("--debug" `elem` args1) $ do