diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index b0b62414c..013ca9369 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -311,7 +311,7 @@ journalRenumberAccountDeclarations j = j{jdeclaredaccounts=jdas'} -- (at debug level 5+). dbgJournalAcctDeclOrder :: String -> Journal -> Journal dbgJournalAcctDeclOrder prefix = - traceOrLogAtWith 5 ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts) + dbg5With ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts) where showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String showAcctDeclsSummary adis diff --git a/hledger-lib/Hledger/Data/Valuation.hs b/hledger-lib/Hledger/Data/Valuation.hs index ee0ca7f36..36c657d4b 100644 --- a/hledger-lib/Hledger/Data/Valuation.hs +++ b/hledger-lib/Hledger/Data/Valuation.hs @@ -97,7 +97,7 @@ journalPriceOracle infer Journal{jpricedirectives, jinferredmarketprices} = declaredprices = map priceDirectiveToMarketPrice jpricedirectives inferredprices = (if infer then jinferredmarketprices else []) - & traceOrLogAt 2 ("use prices inferred from costs? " <> if infer then "yes" else "no") + & dbg2Msg ("use prices inferred from costs? " <> if infer then "yes" else "no") makepricegraph = memo $ makePriceGraph declaredprices inferredprices in memo $ uncurry3 $ priceLookup makepricegraph @@ -264,7 +264,7 @@ priceLookup makepricegraph d from mto = ,pgEdgesRev=allprices ,pgDefaultValuationCommodities=defaultdests } = - traceOrLogAt 1 ("valuation date: "++show d) $ makepricegraph d + dbg1Msg ("valuation date: "++show d) $ makepricegraph d mto' = mto <|> mdefaultto where mdefaultto = dbg1 ("default valuation commodity for "++T.unpack from) $ @@ -279,12 +279,12 @@ priceLookup makepricegraph d from mto = let msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to) prices = - (traceOrLogAt 2 (msg++" using forward prices") $ - traceOrLogAt 2 ("forward prices:\n" <> showMarketPrices forwardprices) $ + (dbg2Msg (msg++" using forward prices") $ + dbg2Msg ("forward prices:\n" <> showMarketPrices forwardprices) $ pricesShortestPath from to forwardprices) <|> - (traceOrLogAt 2 (msg++" using forward and reverse prices") $ - traceOrLogAt 2 ("forward and reverse prices:\n" <> showMarketPrices allprices) $ + (dbg2Msg (msg++" using forward and reverse prices") $ + dbg2Msg ("forward and reverse prices:\n" <> showMarketPrices allprices) $ pricesShortestPath from to $ dbg5 "all forward and reverse prices" allprices) in case prices of Nothing -> Nothing @@ -375,13 +375,8 @@ pricesShortestPath start end edges = case concatMap extend paths of [] -> Nothing _ | pathlength > maxpathlength -> - -- XXX This is unusual: - -- 1. A warning, not an error, which we usually avoid - -- 2. Not a debug message (when triggered, we always print it) - -- 3. Printed either to stdout or (eg in hledger-ui) to the debug log file. - -- This is the only place we use traceOrLog like this. - -- Also before 1.32.2, traceOrLog was doing the opposite of what it should [#2134]. - traceOrLog ("gave up searching for a price chain at length "++show maxpathlength++", please report a bug") + -- Print a non-fatal warning to stderr, something we usually avoid. + warn ("gave up searching for a price chain at length "++show maxpathlength++", please report a bug") Nothing where pathlength = 2 + maybe 0 (length . fst) (headMay paths) diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index 1b7691f19..477b84ca7 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -299,7 +299,7 @@ readJournalFileAndLatestDates iopts prefixedfile = do iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]} liftIO $ requireJournalFileExists f h <- - traceOrLogAt 6 ("readJournalFile: "++takeFileName f) $ + dbg6Msg ("readJournalFile: "++takeFileName f) $ liftIO $ openFileOrStdin f -- <- T.readFile f -- or without line ending translation, for testing j <- readJournal iopts' (Just f) h @@ -331,7 +331,7 @@ readJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal readJournalFiles iopts@InputOpts{strict_, new_, new_save_} prefixedfiles = do let iopts' = iopts{_defer=True} (j, latestdatesforfiles) <- - traceOrLogAt 6 ("readJournalFiles: "++show prefixedfiles) $ + dbg6Msg ("readJournalFiles: "++show prefixedfiles) $ readJournalFilesAndLatestDates iopts' prefixedfiles when strict_ $ liftEither $ journalStrictChecks j when (new_ && new_save_) $ liftIO $ saveLatestDatesForFiles latestdatesforfiles diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 0c498cab9..8a2abdaf6 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -386,7 +386,7 @@ journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_, <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id) -- With --infer-equity, infer equity postings from costs where possible <&> dbg9With (lbl "amounts after equity-inferring".showJournalAmountsDebug) <&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions - -- <&> traceOrLogAt 6 fname -- debug logging + -- <&> dbg6Msg fname -- debug logging <&> dbgJournalAcctDeclOrder (fname <> ": acct decls : ") <&> journalRenumberAccountDeclarations <&> dbgJournalAcctDeclOrder (fname <> ": acct decls renumbered: ") diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 64315283c..aef71e90c 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -338,7 +338,7 @@ includedirectivep = do Fail.fail ("Cyclic include: " ++ filepath) childInput <- - traceOrLogAt 6 ("parseChild: "++takeFileName filepath) $ + dbg6Msg ("parseChild: "++takeFileName filepath) $ lift $ readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) let initChildj = newJournalWithParseStateFrom filepath parentj diff --git a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs index 2c7f96929..03763edd0 100644 --- a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs @@ -125,16 +125,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 mixedAmountStripCosts) - . traceOrLogAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns) + . dbg5With (("ts3:\n"++).pshowTransactions.jtxns) -- maybe convert these transactions to cost or value . journalApplyValuationFromOpts rspec - . traceOrLogAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns) + . dbg5With (("ts2:\n"++).pshowTransactions.jtxns) -- apply any cur: or amt: 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) - . traceOrLogAt 3 ("thisacctq: "++show thisacctq) - $ traceOrLogAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns) + . dbg3Msg ("thisacctq: "++show thisacctq) + $ dbg5With (("ts1:\n"++).pshowTransactions.jtxns) j{jtxns = filter (matchesTransaction thisacctq . relevantPostings) $ jtxns j} where relevantPostings @@ -159,7 +159,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 - . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd) + . dbg5With (("ts4:\n"++).pshowTransactions.map snd) . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd)) . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t)) . map (if invert_ ropts then (\t -> t{tpostings = map postingNegateMainAmount $ tpostings t}) else id) diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index a5071b509..98ce4da93 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -2,42 +2,13 @@ Here are fancier versions of Debug.Trace, with these features: -- unsafePerformIO-based for easy usage in pure code, IO code, and program startup code -- reasonably short and memorable function names -- pretty-printing haskell values, with or without colour, using pretty-simple +- short, memorable, greppable function names +- pretty-printing of haskell values, using pretty-simple +- optional ANSI colour - enabling/disabling debug output with --debug -- multiple debug verbosity levels, from 1 to 9 -- sending debug output to stderr or to a log file -- enabling logging based on program name - -The basic "trace" functions print to stderr. -This debug output will be interleaved with the program's normal output, which can be -useful for understanding when code executes. - -The "Log" functions log to a file instead. -The need for these is arguable, since a technically savvy user can redirect -stderr output to a log file, eg: @CMD 2>debug.log@. -But here is how they currently work: - -The "traceLog" functions log to the program's debug log file, -which is @PROGNAME.log@ in the current directory, -where PROGNAME is the program name returned by @getProgName@. -When using this logging feature you should call @withProgName@ explicitly -at the start of your program to ensure a stable program name, -otherwise it can change to "" eg when running in GHCI. -Eg: @main = withProgName "MYPROG" $ do ...@. - -The "OrLog" functions can either print to stderr or log to a file. - -- By default, they print to stderr. - -- If the program name has been set (with @withProgName) to something ending with ".log", they log to that file instead. - This can be useful for programs which should never print to stderr, eg TUI programs like hledger-ui. - -The "At" functions produce output only when the program was run with a -sufficiently high debug level, as set by a @--debug[=N]@ command line option. -N ranges from 1 (least debug output) to 9 (most debug output), -@--debug@ with no argument means 1. +- debug output levels from 1 to 9, selected by --debug N option +- --debug detected with unsafePerformIO for easy use in pure/IO/startup code +- debug output can be logged instead (for TUI apps) The "dbgN*" functions are intended to be the most convenient API, to be embedded at points of interest in your code. They combine the conditional output of "At", @@ -98,34 +69,79 @@ val module Hledger.Utils.Debug ( - debugLevel + -- * The program's debug level, from 0 (least debug output) to 9 (most). + -- This is parsed from a command line --debug N option, or --debug meaning 1. + -- The command line is read (once) by unsafePerformIO, allowing this to be used + -- easily anywhere in your program. + debugLevel -- * Tracing to stderr - ,traceWith - ,traceAt - ,traceAtWith - ,ptrace - ,ptraceAt - ,ptraceAtIO + -- These print to stderr. + -- This output will be interleaved with the program's normal output, + -- which can be helpful for understanding code execution. + -- + -- ,traceWith + -- ,traceAt + -- ,traceAtWith + -- ,ptrace + -- ,ptraceAt + -- ,ptraceAtIO - -- * Logging to PROGNAME.log - ,traceLog - ,traceLogAt - ,traceLogIO - ,traceLogAtIO - ,traceLogWith - ,traceLogAtWith - ,ptraceLogAt - ,ptraceLogAtIO + -- * Logging to a log file + -- These append to a PROGRAM.log file in the current directory. + -- PROGRAM is normally the name of the executable, but it can change + -- eg when running in GHCI. So when using these, you should call + -- @withProgName@ to ensure a stable program name. + -- Eg: @main = withProgName "PROGRAM" $ do ...@. + -- + -- ,log' + -- ,logAt + -- ,logIO + -- ,logAtIO + -- ,logWith + -- ,logAtWith + -- ,plogAt + -- ,plogAtIO - -- * Tracing or logging based on shouldLog - ,traceOrLog - ,traceOrLogAt - ,ptraceOrLogAt - ,ptraceOrLogAtIO - ,traceOrLogAtWith + -- All @dbg*@ functions normally trace to stderr, + -- but they will log to PROGRAM.log instead if the (internal) program name ends with ".log". + -- Eg: @main = withProgName "PROGRAM.log" $ do ...@. + -- This is intended for TUI programs where stderr output is hard to see. + -- + -- They have an effect only when the program's debug level is at or above the + -- level specified by an argument or by the function name. + -- The many variants follow a consistent pattern and aim to reduce typing and cognitive load. - -- * Pretty tracing/logging in pure code + -- * Trace/log a string + ,dbgMsg + ,dbg0Msg + ,dbg1Msg + ,dbg2Msg + ,dbg3Msg + ,dbg4Msg + ,dbg5Msg + ,dbg6Msg + ,dbg7Msg + ,dbg8Msg + ,dbg9Msg + + -- * In IO + ,dbgMsgIO + ,dbg0MsgIO + ,dbg1MsgIO + ,dbg2MsgIO + ,dbg3MsgIO + ,dbg4MsgIO + ,dbg5MsgIO + ,dbg6MsgIO + ,dbg7MsgIO + ,dbg8MsgIO + ,dbg9MsgIO + + -- * Trace/log a showable value, pretty-printed + -- @dbg@ here clashes with Text.Megaparsec.Debug (dbg), so that module or this one + -- should be imported qualified if you are using both. + ,dbg ,dbg0 ,dbg1 ,dbg2 @@ -136,9 +152,9 @@ module Hledger.Utils.Debug ( ,dbg7 ,dbg8 ,dbg9 - ,dbgExit - -- * Pretty tracing/logging in IO + -- * In IO + ,dbgIO ,dbg0IO ,dbg1IO ,dbg2IO @@ -150,7 +166,8 @@ module Hledger.Utils.Debug ( ,dbg8IO ,dbg9IO - -- * Tracing/logging with a show function + -- * With a custom show function + ,dbgWith ,dbg0With ,dbg1With ,dbg2With @@ -162,12 +179,14 @@ module Hledger.Utils.Debug ( ,dbg8With ,dbg9With - -- * Utilities + -- * Utilities, ghc-debug ,ghcDebugSupportedInLib ,GhcDebugMode(..) ,ghcDebugMode ,withGhcDebug' ,ghcDebugPause' + + -- * Utilities, other ,lbl_ ,progName @@ -182,14 +201,13 @@ import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List hiding (uncons) --- import Debug.Breakpoint import Debug.Trace (trace, traceIO, traceShowId) #ifdef GHCDEBUG import GHC.Debug.Stub (pause, withGhcDebug) #endif import Safe (readDef) import System.Environment (getProgName) -import System.Exit (exitFailure) +-- import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) import Hledger.Utils.IO (progArgs, pshow, pshow') @@ -285,16 +303,8 @@ ghcDebugPause' = return () #endif --- | Trace a value with the given show function before returning it. -traceWith :: (a -> String) -> a -> a -traceWith f a = trace (f a) a --- | 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 - --- | Trace (print to stderr) a string if the global debug level is at +-- | Trace (print to stderr) a string if the program debug level is at -- or above the specified level. At level 0, always prints. Otherwise, -- uses unsafePerformIO. traceAt :: Int -> String -> a -> a @@ -302,14 +312,30 @@ traceAt level | level > 0 && debugLevel < level = const id | otherwise = trace +-- | Like traceAt, but sequences properly in IO. +traceAtIO :: (MonadIO m) => Int -> String -> m () +traceAtIO level msg = + if level > 0 && debugLevel < level + then return () + else liftIO $ traceIO msg + +-- -- | Trace a value with the given show function before returning it. +-- traceWith :: (a -> String) -> a -> a +-- traceWith f a = trace (f a) a + -- | Trace (print to stderr) a showable value using a custom show function, --- if the global debug level is at or above the specified level. +-- if the program debug level is at or above the specified level. -- At level 0, always prints. Otherwise, uses unsafePerformIO. traceAtWith :: Int -> (a -> String) -> a -> a traceAtWith level f a = traceAt level (f a) a +-- -- | 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 + -- | Pretty-print a label and a showable value to the console --- if the global debug level is at or above the specified level. +-- if the program debug level is at or above the specified level. -- At level 0, always prints. Otherwise, uses unsafePerformIO. ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level @@ -326,206 +352,257 @@ labelledPretty allowcolour lbl a = lbl ++ ":" ++ nlorspace ++ intercalate "\n" l ls' | length ls > 1 = map (' ':) ls | otherwise = ls --- | Like ptraceAt, but convenient to insert in an IO monad and --- enforces monadic sequencing. +-- | Like ptraceAt, but sequences properly in IO. ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () ptraceAtIO level label a = if level > 0 && debugLevel < level then return () else liftIO $ traceIO (labelledPretty True label a) --- | Should the "trace or log" functions output to a file instead of stderr ? --- True if the program name ends with ".log". -shouldLog :: Bool -shouldLog = ".log" `isSuffixOf` modifiedProgName -- | The debug log file: PROGNAME.log in the current directory. -- See modifiedProgName. debugLogFile :: FilePath debugLogFile = progName ++ ".log" --- -- | The debug log file: debug.log in the current directory. --- debugLogFile :: FilePath --- debugLogFile = "debug.log" - -- | Log a string to the debug log before returning the second argument. -- Uses unsafePerformIO. -traceLog :: String -> a -> a -traceLog s x = unsafePerformIO $ do +log' :: String -> a -> a +log' s x = unsafePerformIO $ do evaluate (force s) -- to complete any previous logging before we attempt more appendFile debugLogFile (s ++ "\n") return x -- | Log a string to the debug log before returning the second argument, --- if the global debug level is at or above the specified level. +-- if the program debug level is at or above the specified level. -- At level 0, always logs. Otherwise, uses unsafePerformIO. -traceLogAt :: Int -> String -> a -> a -traceLogAt level str +logAt :: Int -> String -> a -> a +logAt level str | level > 0 && debugLevel < level = id - | otherwise = traceLog str + | otherwise = log' str --- | Like traceLog but sequences properly in IO. -traceLogIO :: MonadIO m => String -> m () -traceLogIO s = do +-- | Like log' but sequences properly in IO. +logIO :: MonadIO m => String -> m () +logIO s = do liftIO $ evaluate (force s) -- to complete any previous logging before we attempt more liftIO $ appendFile debugLogFile (s ++ "\n") --- | Like traceLogAt, but convenient to use in IO. -traceLogAtIO :: MonadIO m => Int -> String -> m () -traceLogAtIO level str +-- | Like logAt, but convenient to use in IO. +logAtIO :: (MonadIO m) => Int -> String -> m () +logAtIO level str | level > 0 && debugLevel < level = return () - | otherwise = traceLogIO str + | otherwise = logIO str --- | Log a value to the debug log with the given show function before returning it. -traceLogWith :: (a -> String) -> a -> a -traceLogWith f a = traceLog (f a) a +-- -- | Log a value to the debug log with the given show function before returning it. +-- logWith :: (a -> String) -> a -> a +-- logWith f a = log' (f a) a -- | Log a string to the debug log before returning the second argument, --- if the global debug level is at or above the specified level. +-- if the program debug level is at or above the specified level. -- At level 0, always logs. Otherwise, uses unsafePerformIO. -traceLogAtWith :: Int -> (a -> String) -> a -> a -traceLogAtWith level f a = traceLogAt level (f a) a +logAtWith :: Int -> (a -> String) -> a -> a +logAtWith level f a = logAt level (f a) a -- | Pretty-log a label and showable value to the debug log, --- if the global debug level is at or above the specified level. +-- if the program 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 +plogAt :: (Show a) => Int -> String -> a -> a +plogAt level | level > 0 && debugLevel < level = const id - | otherwise = \lbl a -> traceLog (labelledPretty False lbl a) a + | otherwise = \lbl a -> log' (labelledPretty False lbl a) a --- | Like ptraceAt, but convenient to insert in an IO monad and --- enforces monadic sequencing. -ptraceLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () -ptraceLogAtIO level label a = +-- | Like ptraceAt, but sequences properly in IO. +plogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () +plogAtIO level label a = if level > 0 && debugLevel < level then return () - else traceLogIO (labelledPretty False label a) + else logIO (labelledPretty False label a) --- | Trace or log a string depending on shouldLog, --- before returning the second argument. -traceOrLog :: String -> a -> a -traceOrLog = if shouldLog then traceLog else trace --- | Trace or log a string depending on shouldLog, --- when global debug level is at or above the specified level, --- before returning the second argument. -traceOrLogAt :: Int -> String -> a -> a -traceOrLogAt = if shouldLog then traceLogAt else traceAt +-- | Should dbg* log to a file instead of tracing to stderr ? +-- True if the (internal) program name ends with ".log". +shouldLog :: Bool +shouldLog = ".log" `isSuffixOf` modifiedProgName --- | Pretty-trace or log depending on shouldLog, when global debug level --- is at or above the specified level. -ptraceOrLogAt :: Show a => Int -> String -> a -> a -ptraceOrLogAt = if shouldLog then ptraceLogAt else ptraceAt --- | Like ptraceOrLogAt, but convenient in IO. -ptraceOrLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m () -ptraceOrLogAtIO = if shouldLog then ptraceLogAtIO else ptraceAtIO +-- | Trace or log a string if the program debug level is at or above the specified level, +-- then return the second argument. +dbgMsg :: Int -> String -> a -> a +dbgMsg = if shouldLog then logAt else traceAt --- | Trace or log, with a show function, depending on shouldLog. -traceOrLogAtWith :: Int -> (a -> String) -> a -> a -traceOrLogAtWith = if shouldLog then traceLogAtWith else traceAtWith +dbg0Msg :: String -> a -> a +dbg0Msg = dbgMsg 0 + +dbg1Msg :: String -> a -> a +dbg1Msg = dbgMsg 1 + +dbg2Msg :: String -> a -> a +dbg2Msg = dbgMsg 2 + +dbg3Msg :: String -> a -> a +dbg3Msg = dbgMsg 3 + +dbg4Msg :: String -> a -> a +dbg4Msg = dbgMsg 4 + +dbg5Msg :: String -> a -> a +dbg5Msg = dbgMsg 5 + +dbg6Msg :: String -> a -> a +dbg6Msg = dbgMsg 6 + +dbg7Msg :: String -> a -> a +dbg7Msg = dbgMsg 7 + +dbg8Msg :: String -> a -> a +dbg8Msg = dbgMsg 8 + +dbg9Msg :: String -> a -> a +dbg9Msg = dbgMsg 9 + + +-- | Like dbgMsg, but sequences properly in IO. +dbgMsgIO :: (MonadIO m) => Int -> String -> m () +dbgMsgIO = if shouldLog then logAtIO else traceAtIO + +dbg0MsgIO :: (MonadIO m) => String -> m () +dbg0MsgIO = dbgMsgIO 0 + +dbg1MsgIO :: (MonadIO m) => String -> m () +dbg1MsgIO = dbgMsgIO 1 + +dbg2MsgIO :: (MonadIO m) => String -> m () +dbg2MsgIO = dbgMsgIO 2 + +dbg3MsgIO :: (MonadIO m) => String -> m () +dbg3MsgIO = dbgMsgIO 3 + +dbg4MsgIO :: (MonadIO m) => String -> m () +dbg4MsgIO = dbgMsgIO 4 + +dbg5MsgIO :: (MonadIO m) => String -> m () +dbg5MsgIO = dbgMsgIO 5 + +dbg6MsgIO :: (MonadIO m) => String -> m () +dbg6MsgIO = dbgMsgIO 6 + +dbg7MsgIO :: (MonadIO m) => String -> m () +dbg7MsgIO = dbgMsgIO 7 + +dbg8MsgIO :: (MonadIO m) => String -> m () +dbg8MsgIO = dbgMsgIO 8 + +dbg9MsgIO :: (MonadIO m) => String -> m () +dbg9MsgIO = dbgMsgIO 9 + + +-- | Trace or log a label and showable value, pretty-printed, +-- if the program debug level is at or above the specified level; +-- then return the value. +-- Traces to stderr or logs to a file depending on shouldLog. +dbg :: (Show a) => Int -> String -> a -> a +dbg = if shouldLog then plogAt else ptraceAt --- | Pretty-trace to stderr (or log to debug log) a label and showable value, --- then return it. dbg0 :: Show a => String -> a -> a -dbg0 = ptraceOrLogAt 0 +dbg0 = dbg 0 --- | Pretty-trace to stderr (or log to debug log) a label and showable value --- if the --debug level is high enough, then return the value. --- Uses unsafePerformIO. dbg1 :: Show a => String -> a -> a -dbg1 = ptraceOrLogAt 1 +dbg1 = dbg 1 dbg2 :: Show a => String -> a -> a -dbg2 = ptraceOrLogAt 2 +dbg2 = dbg 2 dbg3 :: Show a => String -> a -> a -dbg3 = ptraceOrLogAt 3 +dbg3 = dbg 3 dbg4 :: Show a => String -> a -> a -dbg4 = ptraceOrLogAt 4 +dbg4 = dbg 4 dbg5 :: Show a => String -> a -> a -dbg5 = ptraceOrLogAt 5 +dbg5 = dbg 5 dbg6 :: Show a => String -> a -> a -dbg6 = ptraceOrLogAt 6 +dbg6 = dbg 6 dbg7 :: Show a => String -> a -> a -dbg7 = ptraceOrLogAt 7 +dbg7 = dbg 7 dbg8 :: Show a => String -> a -> a -dbg8 = ptraceOrLogAt 8 +dbg8 = dbg 8 dbg9 :: Show a => String -> a -> a -dbg9 = ptraceOrLogAt 9 +dbg9 = dbg 9 --- | Like dbg0, but also exit the program. Uses unsafePerformIO. -dbgExit :: Show a => String -> a -> a -dbgExit label a = unsafePerformIO $ dbg0IO label a >> exitFailure --- | Like dbgN, but convenient to use in IO. +-- | Like dbg, but sequences properly in IO. +dbgIO :: (MonadIO m, Show a) => Int -> String -> a -> m () +dbgIO = if shouldLog then plogAtIO else ptraceAtIO + dbg0IO :: (MonadIO m, Show a) => String -> a -> m () -dbg0IO = ptraceOrLogAtIO 0 +dbg0IO = dbgIO 0 dbg1IO :: (MonadIO m, Show a) => String -> a -> m () -dbg1IO = ptraceOrLogAtIO 1 +dbg1IO = dbgIO 1 dbg2IO :: (MonadIO m, Show a) => String -> a -> m () -dbg2IO = ptraceOrLogAtIO 2 +dbg2IO = dbgIO 2 dbg3IO :: (MonadIO m, Show a) => String -> a -> m () -dbg3IO = ptraceOrLogAtIO 3 +dbg3IO = dbgIO 3 dbg4IO :: (MonadIO m, Show a) => String -> a -> m () -dbg4IO = ptraceOrLogAtIO 4 +dbg4IO = dbgIO 4 dbg5IO :: (MonadIO m, Show a) => String -> a -> m () -dbg5IO = ptraceOrLogAtIO 5 +dbg5IO = dbgIO 5 dbg6IO :: (MonadIO m, Show a) => String -> a -> m () -dbg6IO = ptraceOrLogAtIO 6 +dbg6IO = dbgIO 6 dbg7IO :: (MonadIO m, Show a) => String -> a -> m () -dbg7IO = ptraceOrLogAtIO 7 +dbg7IO = dbgIO 7 dbg8IO :: (MonadIO m, Show a) => String -> a -> m () -dbg8IO = ptraceOrLogAtIO 8 +dbg8IO = dbgIO 8 dbg9IO :: (MonadIO m, Show a) => String -> a -> m () -dbg9IO = ptraceOrLogAtIO 9 +dbg9IO = dbgIO 9 + + +-- | Like dbgWith, but with a custom show function. +dbgWith :: Int -> (a -> String) -> a -> a +dbgWith = if shouldLog then logAtWith else traceAtWith -- | Like dbgN, but taking a show function instead of a label. dbg0With :: (a -> String) -> a -> a -dbg0With = traceOrLogAtWith 0 +dbg0With = dbgWith 0 dbg1With :: Show a => (a -> String) -> a -> a -dbg1With = traceOrLogAtWith 1 +dbg1With = dbgWith 1 dbg2With :: Show a => (a -> String) -> a -> a -dbg2With = traceOrLogAtWith 2 +dbg2With = dbgWith 2 dbg3With :: Show a => (a -> String) -> a -> a -dbg3With = traceOrLogAtWith 3 +dbg3With = dbgWith 3 dbg4With :: Show a => (a -> String) -> a -> a -dbg4With = traceOrLogAtWith 4 +dbg4With = dbgWith 4 dbg5With :: Show a => (a -> String) -> a -> a -dbg5With = traceOrLogAtWith 5 +dbg5With = dbgWith 5 dbg6With :: Show a => (a -> String) -> a -> a -dbg6With = traceOrLogAtWith 6 +dbg6With = dbgWith 6 dbg7With :: Show a => (a -> String) -> a -> a -dbg7With = traceOrLogAtWith 7 +dbg7With = dbgWith 7 dbg8With :: Show a => (a -> String) -> a -> a -dbg8With = traceOrLogAtWith 8 +dbg8With = dbgWith 8 dbg9With :: Show a => (a -> String) -> a -> a -dbg9With = traceOrLogAtWith 9 +dbg9With = dbgWith 9 -- | Helper for producing debug messages: -- concatenates a name (eg a function name), @@ -547,5 +624,5 @@ lbl_ name desc val = name <> ": " <> desc <> ":" <> " " <> val -- dbg_ :: forall a. Show a => Int -> String -> (String -> (a -> String) -> a -> a) -- dbg_ level topic = -- \desc showfn val -> --- traceOrLogAtWith level (lbl_ topic desc . showfn) val +-- dbgWith level (lbl_ topic desc . showfn) val -- {-# HLINT ignore "Redundant lambda" #-} diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs index 74b06f5e2..c5c0fc6d0 100644 --- a/hledger-lib/Hledger/Utils/Parse.hs +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -47,7 +47,6 @@ module Hledger.Utils.Parse ( -- ** Trace the state of hledger parsers dbgparse, - traceOrLogParse, -- * More helpers, previously in Text.Megaparsec.Custom @@ -111,7 +110,7 @@ import qualified Data.List.NonEmpty as NE import Data.Monoid (Alt(..)) import qualified Data.Set as S -import Hledger.Utils.Debug (debugLevel, traceOrLog) +import Hledger.Utils.Debug (debugLevel, dbg0Msg) -- | A parser of string to some type. type SimpleStringParser a = Parsec HledgerParseErrorData String a @@ -128,23 +127,17 @@ type TextParser m a = ParsecT HledgerParseErrorData Text m a -- | Trace to stderr or log to debug log the provided label (if non-null) -- and current parser state (position and next input), -- if the global debug level is at or above the specified level. --- Uses unsafePerformIO. -dbgparse :: Int -> String -> TextParser m () -dbgparse level msg = when (level <= debugLevel) $ traceOrLogParse msg - --- | Trace to stderr or log to debug log the provided label (if non-null) --- and current parser state (position and next input). -- See also: Hledger.Utils.Debug, megaparsec's dbg. -- Uses unsafePerformIO. -- XXX Can be hard to make this evaluate. -traceOrLogParse :: String -> TextParser m () -traceOrLogParse msg = do +dbgparse :: Int -> String -> TextParser m () +dbgparse level msg = when (level <= debugLevel) $ do pos <- getSourcePos next <- (T.take peeklength) `fmap` getInput let (l,c) = (sourceLine pos, sourceColumn pos) s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg - traceOrLog s' $ return () + dbg0Msg s' $ return () where peeklength = 30 diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 91b2307a7..4aad61895 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -92,7 +92,7 @@ hledgerUiMain = exitOnError $ withGhcDebug' $ withProgName "hledger-ui.log" $ do #endif #endif - traceLogAtIO 1 "\n\n\n\n==== hledger-ui start" + dbg1MsgIO "\n\n\n\n==== hledger-ui start" dbg1IO "args" progArgs dbg1IO "debugLevel" debugLevel diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs index 285239fbb..4e0c07508 100644 --- a/hledger-ui/Hledger/UI/UIUtils.hs +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -451,15 +451,15 @@ listScrollPushingSelection name listheight scrollamt = do -- logs the string to hledger-ui.log before returning the second argument. -- Uses unsafePerformIO. dbgui :: String -> a -> a -dbgui = traceLogAt 1 +dbgui = dbg1Msg -- | Like dbgui, but convenient to use in IO. dbguiIO :: String -> IO () -dbguiIO = traceLogAtIO 1 +dbguiIO = dbg1MsgIO -- | Like dbgui, but convenient to use in EventM handlers. dbguiEv :: String -> EventM Name s () -dbguiEv s = dbgui s $ return () +dbguiEv s = dbg1Msg s $ return () -- | Like dbguiEv, but log a compact view of the current screen stack. -- See showScreenStack. diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index dae5f9ca8..b10afd584 100644 --- a/hledger/Hledger/Cli.hs +++ b/hledger/Hledger/Cli.hs @@ -218,13 +218,10 @@ main = exitOnError $ withGhcDebug' $ do -- 0. let's go! let - -- Trace helpers. These always trace to stderr, even when running `hledger ui`; - -- that's ok as conf is a hledger cli feature for now. - dbgIO, dbgIO1, dbgIO2 :: Show a => String -> a -> IO () -- this signature is needed - dbgIO = ptraceAtIO verboseDebugLevel - dbgIO1 = ptraceAtIO 1 - dbgIO2 = ptraceAtIO 2 - dbgIO "running" prognameandversion + dbgio :: Show a => String -> a -> IO () + dbgio = dbgIO verboseDebugLevel + + dbgio "running" prognameandversion starttime <- getPOSIXTime -- give ghc-debug a chance to take control when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause' @@ -235,7 +232,7 @@ main = exitOnError $ withGhcDebug' $ do addons <- addonCommandNames --------------------------------------------------------------- - dbgIO "\n1. Preliminary command line parsing" () + dbgio "\n1. Preliminary command line parsing" () -- Naming notes: -- "arg" often has the most general meaning, including things like: -f, --flag, flagvalue, arg, >file, &, etc. @@ -252,15 +249,15 @@ main = exitOnError $ withGhcDebug' $ do (clicmdarg, cliargswithoutcmd, cliargswithcmdfirst) = moveFlagsAfterCommand cliargs cliargswithcmdfirstwithoutclispecific = dropCliSpecificOpts cliargswithcmdfirst (cliargsbeforecmd, cliargsaftercmd) = second (drop 1) $ break (==clicmdarg) cliargs - dbgIO "cli args with preprocessing" cliargs + dbgio "cli args with preprocessing" cliargs dbg1IO "cli args with preprocessing and options moved after command" cliargswithcmdfirst - dbgIO "cli command argument found" clicmdarg - dbgIO "cli args before command" cliargsbeforecmd - dbgIO "cli args after command" cliargsaftercmd - -- dbgIO "cli args without command" cliargswithoutcmd + dbgio "cli command argument found" clicmdarg + dbgio "cli args before command" cliargsbeforecmd + dbgio "cli args after command" cliargsaftercmd + -- dbgio "cli args without command" cliargswithoutcmd --------------------------------------------------------------- - dbgIO "\n2. Read the config file if any" () + dbgio "\n2. Read the config file if any" () -- Identify any --conf/--no-conf options. -- Run cmdargs on just the args that look conf-related. @@ -276,7 +273,7 @@ main = exitOnError $ withGhcDebug' $ do else getConf' cliconfrawopts --------------------------------------------------------------- - dbgIO "\n3. Identify a command name from config file or command line" () + dbgio "\n3. Identify a command name from config file or command line" () -- Try to identify the subcommand name, -- from the first non-flag general argument in the config file, @@ -310,15 +307,15 @@ main = exitOnError $ withGhcDebug' $ do when (isJust mconffile) $ do unless (null confcmdarg) $ - dbgIO1 "using command name argument from config file" confcmdarg - dbgIO "cli args with command first and no cli-specific opts" cliargswithcmdfirstwithoutclispecific - dbgIO1 "command found" cmdname - dbgIO "no command provided" nocmdprovided - dbgIO "bad command provided" badcmdprovided - dbgIO "is addon command" isaddoncmd + dbg1IO "using command name argument from config file" confcmdarg + dbgio "cli args with command first and no cli-specific opts" cliargswithcmdfirstwithoutclispecific + dbg1IO "command found" cmdname + dbgio "no command provided" nocmdprovided + dbgio "bad command provided" badcmdprovided + dbgio "is addon command" isaddoncmd --------------------------------------------------------------- - dbgIO "\n4. Get applicable options/arguments from config file" () + dbgio "\n4. Get applicable options/arguments from config file" () -- Ignore any general opts or cli-specific opts not known to be supported by the command. let @@ -337,13 +334,13 @@ main = exitOnError $ withGhcDebug' $ do & if isaddoncmd then ("--":) else id when (isJust mconffile) $ do - dbgIO1 "using general args from config file" confothergenargs + dbg1IO "using general args from config file" confothergenargs unless (null excludedgenargsfromconf) $ - dbgIO1 "excluded general args from config file, not supported by this command" excludedgenargsfromconf - dbgIO1 "using subcommand args from config file" confcmdargs + dbg1IO "excluded general args from config file, not supported by this command" excludedgenargsfromconf + dbg1IO "using subcommand args from config file" confcmdargs --------------------------------------------------------------- - dbgIO "\n5. Combine config file and command line args" () + dbgio "\n5. Combine config file and command line args" () let finalargs = @@ -355,7 +352,7 @@ main = exitOnError $ withGhcDebug' $ do & replaceNumericFlags -- convert any -NUM opts from the config file -- finalargs' <- expandArgsAt finalargs -- expand @ARGFILEs in the config file ? don't bother - dbgIO1 "final args" finalargs + dbg1IO "final args" finalargs -- Run cmdargs on command name + supported conf general args + conf subcommand args + cli args to get the final options. -- A bad flag or flag argument will cause the program to exit with an error here. @@ -363,7 +360,7 @@ main = exitOnError $ withGhcDebug' $ do --------------------------------------------------------------- seq rawopts $ -- order debug output - dbgIO "\n6. Select an action and run it" () + dbgio "\n6. Select an action and run it" () -- We check for the help/doc/version flags first, since they are a high priority. -- (A perfectionist might think they should be so high priority that adding -h @@ -381,10 +378,10 @@ main = exitOnError $ withGhcDebug' $ do -- validate opts/args more and convert to CliOpts opts <- rawOptsToCliOpts rawopts >>= \opts0 -> return opts0{progstarttime_=starttime} - dbgIO2 "processed opts" opts - dbgIO "period from opts" (period_ . _rsReportOpts $ reportspec_ opts) - dbgIO "interval from opts" (interval_ . _rsReportOpts $ reportspec_ opts) - dbgIO "query from opts & args" (_rsQuery $ reportspec_ opts) + dbg2IO "processed opts" opts + dbgio "period from opts" (period_ . _rsReportOpts $ reportspec_ opts) + dbgio "interval from opts" (interval_ . _rsReportOpts $ reportspec_ opts) + dbgio "query from opts & args" (_rsQuery $ reportspec_ opts) -- Ensure that anything calling getArgs later will see all args, including config file args. -- Some things (--color, --debug, some checks in journalFinalise) are detected by unsafePerformIO, @@ -406,13 +403,13 @@ main = exitOnError $ withGhcDebug' $ do -- 6.4. no command found, nothing else to do - show the commands list | nocmdprovided -> do - dbgIO1 "no command, showing commands list" () + dbg1IO "no command, showing commands list" () commands opts (ignoredjournal "commands") -- 6.5. builtin command found | Just (cmdmode, cmdaction) <- mbuiltincmdaction -> do let mmodecmdname = headMay $ modeNames cmdmode - dbgIO1 "running builtin command mode" $ fromMaybe "" mmodecmdname + dbg1IO "running builtin command mode" $ fromMaybe "" mmodecmdname -- run the builtin command according to its type if @@ -453,9 +450,9 @@ main = exitOnError $ withGhcDebug' $ do addonargs0 = filter (/="--") $ supportedgenargsfromconf <> confcmdargs <> cliargswithoutcmd addonargs = dropCliSpecificOpts addonargs0 shellcmd = printf "%s-%s %s" progname cmdname (unwords' addonargs) :: String - dbgIO "addon command selected" cmdname - dbgIO "addon command arguments after removing cli-specific opts" (map quoteIfNeeded addonargs) - dbgIO1 "running addon" shellcmd + dbgio "addon command selected" cmdname + dbgio "addon command arguments after removing cli-specific opts" (map quoteIfNeeded addonargs) + dbg1IO "running addon" shellcmd system shellcmd >>= exitWith -- deprecated command found @@ -496,7 +493,7 @@ cmdargsParse :: String -> Mode RawOpts -> [String] -> RawOpts cmdargsParse desc m args0 = process m (ensureDebugFlagHasVal args0) & either (\e -> error' $ e <> "\n* while parsing the following args, " <> desc <> ":\n* " <> unwords (map quoteIfNeeded args0)) - (traceOrLogAt verboseDebugLevel ("cmdargs: parsing " <> desc <> ": " <> show args0)) + (dbgMsg verboseDebugLevel ("cmdargs: parsing " <> desc <> ": " <> show args0)) -- XXX better error message when cmdargs fails (eg spaced/quoted/malformed flag values) ? -- | cmdargs does not allow options to appear before the subcommand argument. @@ -558,12 +555,12 @@ moveFlagsAfterCommand args = moveFlagAndVal :: ([String], [String]) -> ([String], [String]) moveFlagAndVal ((a:b:cs), moved) = case isMovableFlagArg a (Just b) of - 2 -> traceOrLogAt lvl ("moving 2: "<>a<>" "<>b) $ moveFlagAndVal (cs, moved++[a,b]) - 1 -> traceOrLogAt lvl ("moving 1: "<>a) $ moveFlagAndVal (b:cs, moved++[a]) + 2 -> dbgMsg lvl ("moving 2: "<>a<>" "<>b) $ moveFlagAndVal (cs, moved++[a,b]) + 1 -> dbgMsg lvl ("moving 1: "<>a) $ moveFlagAndVal (b:cs, moved++[a]) _ -> (a:b:cs, moved) moveFlagAndVal ([a], moved) = case isMovableFlagArg a Nothing of - 1 -> traceOrLogAt lvl ("moving 1: "<>a) ([], moved++[a]) + 1 -> dbgMsg lvl ("moving 1: "<>a) ([], moved++[a]) _ -> ([a], moved) moveFlagAndVal ([], moved) = ([], moved) lvl = 8 diff --git a/hledger/Hledger/Cli/Conf.hs b/hledger/Hledger/Cli/Conf.hs index d90de20c5..42d1b596f 100644 --- a/hledger/Hledger/Cli/Conf.hs +++ b/hledger/Hledger/Cli/Conf.hs @@ -107,13 +107,13 @@ getConf rawopts = do -- As in Cli.hs, conf debug output always goes to stderr; -- that's ok as conf is a hledger cli feature for now. case confFileSpecFromRawOpts rawopts of - NoConfFile -> return $ Right $ traceAt 1 "ignoring config files" (nullconf, Nothing) + NoConfFile -> return $ Right $ dbg1Msg "ignoring config files" (nullconf, Nothing) SomeConfFile f -> getCurrentDirectory >>= flip expandPath f >>= readConfFile . dbg1 "using specified config file" AutoConfFile -> do fs <- confFiles case fs of f:_ -> dbg8IO "found config files" fs >> dbg1IO "using nearest config file" f >> readConfFile f - [] -> return $ Right $ traceAt 1 "no config file found" (nullconf, Nothing) + [] -> return $ Right $ dbg1Msg "no config file found" (nullconf, Nothing) -- | Like getConf but throws an error on failure. getConf' :: RawOpts -> IO (Conf, Maybe FilePath)