slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some cleanup of debug trace helpers

Browse Source
This commit is contained in:
Simon Michael 2015-05-14 12:49:17 -07:00
parent a61d49cca6
commit 70d87613f2
12 changed files with 165 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hledger-lib/Hledger/Data/Journal.hs
View File

@ -495,7 +495,7 @@ journalCanonicaliseAmounts :: Journal -> Journal
journalCanonicaliseAmounts j@Journal{jtxns=ts} = j'' journalCanonicaliseAmounts j@Journal{jtxns=ts} = j''
where where
j'' = j'{jtxns=map fixtransaction ts} j'' = j'{jtxns=map fixtransaction ts}
j' = j{jcommoditystyles = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j} j' = j{jcommoditystyles = canonicalStyles $ dbg8 "journalAmounts" $ journalAmounts j}
fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
fixmixedamount (Mixed as) = Mixed $ map fixamount as fixmixedamount (Mixed as) = Mixed $ map fixamount as

6
hledger-lib/Hledger/Read.hs
View File

@ -126,9 +126,9 @@ readJournal format rulesfile assrt path s =
firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal) firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal)
firstSuccessOrBestError [] [] = return $ Left "no readers found" firstSuccessOrBestError [] [] = return $ Left "no readers found"
firstSuccessOrBestError errs (r:rs) = do firstSuccessOrBestError errs (r:rs) = do
dbgAtM 1 "trying reader" (rFormat r) dbg1IO "trying reader" (rFormat r)
result <- (runExceptT . (rParser r) rulesfile assrt path') s result <- (runExceptT . (rParser r) rulesfile assrt path') s
dbgAtM 1 "reader result" $ either id show result dbg1IO "reader result" $ either id show result
case result of Right j -> return $ Right j -- success! case result of Right j -> return $ Right j -- success!
Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying
firstSuccessOrBestError (e:_) [] = return $ Left e -- none left, return first error firstSuccessOrBestError (e:_) [] = return $ Left e -- none left, return first error
@ -137,7 +137,7 @@ readJournal format rulesfile assrt path s =
-- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ? -- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ?
readersFor :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader] readersFor :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader]
readersFor (format,path,s) = readersFor (format,path,s) =
dbg ("possible readers for "++show (format,path,elideRight 30 s)) $ dbg1 ("possible readers for "++show (format,path,elideRight 30 s)) $
case format of case format of
Just f -> case readerForStorageFormat f of Just r -> [r] Just f -> case readerForStorageFormat f of Just r -> [r]
Nothing -> [] Nothing -> []

8
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -101,7 +101,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
let rules = case rules_ of let rules = case rules_ of
Right (t::CsvRules) -> t Right (t::CsvRules) -> t
Left err -> throwerr $ show err Left err -> throwerr $ show err
dbgAtM 2 "rules" rules dbg2IO "rules" rules
-- apply skip directive -- apply skip directive
let skip = maybe 0 oneorerror $ getDirective "skip" rules let skip = maybe 0 oneorerror $ getDirective "skip" rules
@ -113,10 +113,10 @@ readJournalFromCsv mrulesfile csvfile csvdata =
-- parsec seems to fail if you pass it "-" here -- parsec seems to fail if you pass it "-" here
let parsecfilename = if csvfile == "-" then "(stdin)" else csvfile let parsecfilename = if csvfile == "-" then "(stdin)" else csvfile
records <- (either throwerr id . records <- (either throwerr id .
dbgAt 2 "validateCsv" . validateCsv skip . dbg2 "validateCsv" . validateCsv skip .
dbgAt 2 "parseCsv") dbg2 "parseCsv")
`fmap` parseCsv parsecfilename csvdata `fmap` parseCsv parsecfilename csvdata
dbgAtM 1 "first 3 csv records" $ take 3 records dbg1IO "first 3 csv records" $ take 3 records
-- identify header lines -- identify header lines
-- let (headerlines, datalines) = identifyHeaderLines records -- let (headerlines, datalines) = identifyHeaderLines records

4
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -823,7 +823,7 @@ numberp = do
-- ptrace "numberp" -- ptrace "numberp"
sign <- signp sign <- signp
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
dbgAt 8 "numberp parsed" (sign,parts) `seq` return () dbg8 "numberp parsed" (sign,parts) `seq` return ()
-- check the number is well-formed and identify the decimal point and digit -- check the number is well-formed and identify the decimal point and digit
-- group separator characters used, if any -- group separator characters used, if any
@ -861,7 +861,7 @@ numberp = do
frac' = if null frac then "0" else frac frac' = if null frac then "0" else frac
quantity = read $ sign++int'++"."++frac' -- this read should never fail quantity = read $ sign++int'++"."++frac' -- this read should never fail
return $ dbgAt 8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps) return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps)
<?> "numberp" <?> "numberp"
where where
numeric = isNumber . headDef '_' numeric = isNumber . headDef '_'

16
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -62,19 +62,19 @@ flatShowsExclusiveBalance = True
balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReport opts q j = (items, total) balanceReport opts q j = (items, total)
where where
-- dbg = const id -- exclude from debug output -- dbg1 = const id -- exclude from debug output
dbg s = let p = "balanceReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in debug output dbg1 s = let p = "balanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in debug output
accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j
accts' :: [Account] accts' :: [Account]
| queryDepth q == 0 = | queryDepth q == 0 =
dbg "accts" $ dbg1 "accts" $
take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts
| flat_ opts = dbg "accts" $ | flat_ opts = dbg1 "accts" $
filterzeros $ filterzeros $
filterempty $ filterempty $
drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts
| otherwise = dbg "accts" $ | otherwise = dbg1 "accts" $
filter (not.aboring) $ filter (not.aboring) $
drop 1 $ flattenAccounts $ drop 1 $ flattenAccounts $
markboring $ markboring $
@ -86,9 +86,9 @@ balanceReport opts q j = (items, total)
filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a))) filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a)))
prunezeros = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance) prunezeros = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance)
markboring = if no_elide_ opts then id else markBoringParentAccounts markboring = if no_elide_ opts then id else markBoringParentAccounts
items = dbg "items" $ map (balanceReportItem opts q) accts' items = dbg1 "items" $ map (balanceReportItem opts q) accts'
total | not (flat_ opts) = dbg "total" $ sum [amt | ((_,_,indent),amt) <- items, indent == 0] total | not (flat_ opts) = dbg1 "total" $ sum [amt | ((_,_,indent),amt) <- items, indent == 0]
| otherwise = dbg "total" $ | otherwise = dbg1 "total" $
if flatShowsExclusiveBalance if flatShowsExclusiveBalance
then sum $ map snd items then sum $ map snd items
else sum $ map aebalance $ clipAccountsAndAggregate 1 accts' else sum $ map aebalance $ clipAccountsAndAggregate 1 accts'

62
hledger-lib/Hledger/Reports/MultiBalanceReports.hs
View File

@ -73,41 +73,41 @@ type ClippedAccountName = AccountName
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow) multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow)
where where
symq = dbg "symq" $ filterQuery queryIsSym $ dbg "requested q" q symq = dbg1 "symq" $ filterQuery queryIsSym $ dbg1 "requested q" q
depthq = dbg "depthq" $ filterQuery queryIsDepth q depthq = dbg1 "depthq" $ filterQuery queryIsDepth q
depth = queryDepth depthq depth = queryDepth depthq
depthless = dbg "depthless" . filterQuery (not . queryIsDepth) depthless = dbg1 "depthless" . filterQuery (not . queryIsDepth)
datelessq = dbg "datelessq" $ filterQuery (not . queryIsDateOrDate2) q datelessq = dbg1 "datelessq" $ filterQuery (not . queryIsDateOrDate2) q
dateqcons = if date2_ opts then Date2 else Date dateqcons = if date2_ opts then Date2 else Date
precedingq = dbg "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)] precedingq = dbg1 "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)]
requestedspan = dbg "requestedspan" $ queryDateSpan (date2_ opts) q -- span specified by -b/-e/-p options and query args requestedspan = dbg1 "requestedspan" $ queryDateSpan (date2_ opts) q -- span specified by -b/-e/-p options and query args
requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j -- if open-ended, close it using the journal's end dates requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j -- if open-ended, close it using the journal's end dates
intervalspans = dbg "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it intervalspans = dbg1 "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it
reportspan = dbg "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans) -- the requested span enlarged to a whole number of intervals reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans) -- the requested span enlarged to a whole number of intervals
(maybe Nothing spanEnd $ lastMay intervalspans) (maybe Nothing spanEnd $ lastMay intervalspans)
newdatesq = dbg "newdateq" $ dateqcons reportspan newdatesq = dbg1 "newdateq" $ dateqcons reportspan
reportq = dbg "reportq" $ depthless $ And [datelessq, newdatesq] -- user's query enlarged to whole intervals and with no depth limit reportq = dbg1 "reportq" $ depthless $ And [datelessq, newdatesq] -- user's query enlarged to whole intervals and with no depth limit
ps :: [Posting] = ps :: [Posting] =
dbg "ps" $ dbg1 "ps" $
journalPostings $ journalPostings $
filterJournalAmounts symq $ -- remove amount parts excluded by cur: filterJournalAmounts symq $ -- remove amount parts excluded by cur:
filterJournalPostings reportq $ -- remove postings not matched by (adjusted) query filterJournalPostings reportq $ -- remove postings not matched by (adjusted) query
journalSelectingAmountFromOpts opts j journalSelectingAmountFromOpts opts j
displayspans = dbg "displayspans" $ splitSpan (intervalFromOpts opts) displayspan displayspans = dbg1 "displayspans" $ splitSpan (intervalFromOpts opts) displayspan
where where
displayspan displayspan
| empty_ opts = dbg "displayspan (-E)" $ reportspan -- all the requested intervals | empty_ opts = dbg1 "displayspan (-E)" $ reportspan -- all the requested intervals
| otherwise = dbg "displayspan" $ requestedspan `spanIntersect` matchedspan -- exclude leading/trailing empty intervals | otherwise = dbg1 "displayspan" $ requestedspan `spanIntersect` matchedspan -- exclude leading/trailing empty intervals
matchedspan = dbg "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps matchedspan = dbg1 "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps
psPerSpan :: [[Posting]] = psPerSpan :: [[Posting]] =
dbg "psPerSpan" $ dbg1 "psPerSpan" $
[filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans] [filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans]
postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =
dbg "postedAcctBalChangesPerSpan" $ dbg1 "postedAcctBalChangesPerSpan" $
map postingAcctBals psPerSpan map postingAcctBals psPerSpan
where where
postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)] postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)]
@ -120,36 +120,36 @@ multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow
| tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances | tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances
| otherwise = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit | otherwise = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit
postedAccts :: [AccountName] = dbg "postedAccts" $ sort $ accountNamesFromPostings ps postedAccts :: [AccountName] = dbg1 "postedAccts" $ sort $ accountNamesFromPostings ps
-- starting balances and accounts from transactions before the report start date -- starting balances and accounts from transactions before the report start date
startacctbals = dbg "startacctbals" $ map (\((a,_,_),b) -> (a,b)) startbalanceitems startacctbals = dbg1 "startacctbals" $ map (\((a,_,_),b) -> (a,b)) startbalanceitems
where where
(startbalanceitems,_) = dbg "starting balance report" $ balanceReport opts' precedingq j (startbalanceitems,_) = dbg1 "starting balance report" $ balanceReport opts' precedingq j
where where
opts' | tree_ opts = opts{no_elide_=True} opts' | tree_ opts = opts{no_elide_=True}
| otherwise = opts{accountlistmode_=ALFlat} | otherwise = opts{accountlistmode_=ALFlat}
startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals
startAccts = dbg "startAccts" $ map fst startacctbals startAccts = dbg1 "startAccts" $ map fst startacctbals
displayedAccts :: [ClippedAccountName] = displayedAccts :: [ClippedAccountName] =
dbg "displayedAccts" $ dbg1 "displayedAccts" $
(if tree_ opts then expandAccountNames else id) $ (if tree_ opts then expandAccountNames else id) $
nub $ map (clipOrEllipsifyAccountName depth) $ nub $ map (clipOrEllipsifyAccountName depth) $
if empty_ opts then nub $ sort $ startAccts ++ postedAccts else postedAccts if empty_ opts then nub $ sort $ startAccts ++ postedAccts else postedAccts
acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =
dbg "acctBalChangesPerSpan" $ dbg1 "acctBalChangesPerSpan" $
[sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes
| postedacctbals <- postedAcctBalChangesPerSpan] | postedacctbals <- postedAcctBalChangesPerSpan]
where zeroes = [(a, nullmixedamt) | a <- displayedAccts] where zeroes = [(a, nullmixedamt) | a <- displayedAccts]
acctBalChanges :: [(ClippedAccountName, [MixedAmount])] = acctBalChanges :: [(ClippedAccountName, [MixedAmount])] =
dbg "acctBalChanges" $ dbg1 "acctBalChanges" $
[(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null... [(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null...
items :: [MultiBalanceReportRow] = items :: [MultiBalanceReportRow] =
dbg "items" $ dbg1 "items" $
[((a, accountLeafName a, accountNameLevel a), displayedBals, rowtot, rowavg) [((a, accountLeafName a, accountNameLevel a), displayedBals, rowtot, rowavg)
| (a,changes) <- acctBalChanges | (a,changes) <- acctBalChanges
, let displayedBals = case balancetype_ opts of , let displayedBals = case balancetype_ opts of
@ -162,18 +162,18 @@ multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow
] ]
totals :: [MixedAmount] = totals :: [MixedAmount] =
-- dbg "totals" $ -- dbg1 "totals" $
map sum balsbycol map sum balsbycol
where where
balsbycol = transpose [bs | ((a,_,_),bs,_,_) <- items, not (tree_ opts) || a `elem` highestlevelaccts] balsbycol = transpose [bs | ((a,_,_),bs,_,_) <- items, not (tree_ opts) || a `elem` highestlevelaccts]
highestlevelaccts = highestlevelaccts =
dbg "highestlevelaccts" $ dbg1 "highestlevelaccts" $
[a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a] [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a]
totalsrow :: MultiBalanceTotalsRow = totalsrow :: MultiBalanceTotalsRow =
dbg "totalsrow" $ dbg1 "totalsrow" $
(totals, sum totals, averageMixedAmounts totals) (totals, sum totals, averageMixedAmounts totals)
dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in this function's debug output dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in this function's debug output
-- dbg = const id -- exclude this function from debug output -- dbg1 = const id -- exclude this function from debug output

36
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -54,7 +54,7 @@ postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport
postingsReport opts q j = (totallabel, items) postingsReport opts q j = (totallabel, items)
where where
-- figure out adjusted queries & spans like multiBalanceReport -- figure out adjusted queries & spans like multiBalanceReport
symq = dbg "symq" $ filterQuery queryIsSym $ dbg "requested q" q symq = dbg1 "symq" $ filterQuery queryIsSym $ dbg1 "requested q" q
depth = queryDepth q depth = queryDepth q
depthless = filterQuery (not . queryIsDepth) depthless = filterQuery (not . queryIsDepth)
datelessq = filterQuery (not . queryIsDateOrDate2) q datelessq = filterQuery (not . queryIsDateOrDate2) q
@ -62,23 +62,23 @@ postingsReport opts q j = (totallabel, items)
dateq = filterQuery queryIsDateOrDate2 q dateq = filterQuery queryIsDateOrDate2 q
(dateqcons,pdate) | queryIsDate2 dateq || (queryIsDate dateq && date2_ opts) = (Date2, postingDate2) (dateqcons,pdate) | queryIsDate2 dateq || (queryIsDate dateq && date2_ opts) = (Date2, postingDate2)
| otherwise = (Date, postingDate) | otherwise = (Date, postingDate)
requestedspan = dbg "requestedspan" $ queryDateSpan' q -- span specified by -b/-e/-p options and query args requestedspan = dbg1 "requestedspan" $ queryDateSpan' q -- span specified by -b/-e/-p options and query args
requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan ({-date2_ opts-} False) j -- if open-ended, close it using the journal's end dates requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan ({-date2_ opts-} False) j -- if open-ended, close it using the journal's end dates
intervalspans = dbg "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it intervalspans = dbg1 "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it
reportstart = dbg "reportstart" $ maybe Nothing spanStart $ headMay intervalspans reportstart = dbg1 "reportstart" $ maybe Nothing spanStart $ headMay intervalspans
reportend = dbg "reportend" $ maybe Nothing spanEnd $ lastMay intervalspans reportend = dbg1 "reportend" $ maybe Nothing spanEnd $ lastMay intervalspans
reportspan = dbg "reportspan" $ DateSpan reportstart reportend -- the requested span enlarged to a whole number of intervals reportspan = dbg1 "reportspan" $ DateSpan reportstart reportend -- the requested span enlarged to a whole number of intervals
beforestartq = dbg "beforestartq" $ dateqcons $ DateSpan Nothing reportstart beforestartq = dbg1 "beforestartq" $ dateqcons $ DateSpan Nothing reportstart
beforeendq = dbg "beforeendq" $ dateqcons $ DateSpan Nothing reportend beforeendq = dbg1 "beforeendq" $ dateqcons $ DateSpan Nothing reportend
reportq = dbg "reportq" $ depthless $ And [datelessq, beforeendq] -- user's query with no start date, end date on an interval boundary and no depth limit reportq = dbg1 "reportq" $ depthless $ And [datelessq, beforeendq] -- user's query with no start date, end date on an interval boundary and no depth limit
pstoend = pstoend =
dbg "ps4" $ sortBy (comparing pdate) $ -- sort postings by date (or date2) dbg1 "ps4" $ sortBy (comparing pdate) $ -- sort postings by date (or date2)
dbg "ps3" $ map (filterPostingAmount symq) $ -- remove amount parts which the query's cur: terms would exclude dbg1 "ps3" $ map (filterPostingAmount symq) $ -- remove amount parts which the query's cur: terms would exclude
dbg "ps2" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings dbg1 "ps2" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings
dbg "ps1" $ filter (reportq `matchesPosting`) $ -- filter postings by the query, including before the report start date, ignoring depth dbg1 "ps1" $ filter (reportq `matchesPosting`) $ -- filter postings by the query, including before the report start date, ignoring depth
journalPostings $ journalSelectingAmountFromOpts opts j journalPostings $ journalSelectingAmountFromOpts opts j
(precedingps, reportps) = dbg "precedingps, reportps" $ span (beforestartq `matchesPosting`) pstoend (precedingps, reportps) = dbg1 "precedingps, reportps" $ span (beforestartq `matchesPosting`) pstoend
showempty = queryEmpty q || average_ opts showempty = queryEmpty q || average_ opts
-- displayexpr = display_ opts -- XXX -- displayexpr = display_ opts -- XXX
@ -87,14 +87,14 @@ postingsReport opts q j = (totallabel, items)
whichdate = whichDateFromOpts opts whichdate = whichDateFromOpts opts
itemps | interval == NoInterval = map (,Nothing) reportps itemps | interval == NoInterval = map (,Nothing) reportps
| otherwise = summarisePostingsByInterval interval whichdate depth showempty reportspan reportps | otherwise = summarisePostingsByInterval interval whichdate depth showempty reportspan reportps
items = dbg "items" $ postingsReportItems itemps (nullposting,Nothing) whichdate depth startbal runningcalc 1 items = dbg1 "items" $ postingsReportItems itemps (nullposting,Nothing) whichdate depth startbal runningcalc 1
where where
startbal = if balancetype_ opts == HistoricalBalance then sumPostings precedingps else 0 startbal = if balancetype_ opts == HistoricalBalance then sumPostings precedingps else 0
runningcalc | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) -- running average runningcalc | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) -- running average
| otherwise = \_ bal amt -> bal + amt -- running total | otherwise = \_ bal amt -> bal + amt -- running total
dbg s = let p = "postingsReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in debug output dbg1 s = let p = "postingsReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in debug output
-- dbg = const id -- exclude from debug output -- dbg1 = const id -- exclude from debug output
totallabel = "Total" totallabel = "Total"

104
hledger-lib/Hledger/Utils/Debug.hs
View File

@ -86,65 +86,93 @@ debugLevel = case snd $ break (=="--debug") args of
where where
args = unsafePerformIO getArgs args = unsafePerformIO getArgs
-- | Print a message and a showable value to the console if the global -- | Convenience aliases for tracePrettyAt.
-- debug level is non-zero. Uses unsafePerformIO. -- Pretty-print a message and the showable value to the console, then return it.
dbg :: Show a => String -> a -> a dbg :: Show a => String -> a -> a
dbg = dbg1 dbg = tracePrettyAt 0
-- always prints
dbg0 :: Show a => String -> a -> a
dbg0 = dbgAt 0
-- | Pretty-print a message and the showable value to the console when the debug level is >= 1, then return it. Uses unsafePerformIO.
dbg1 :: Show a => String -> a -> a dbg1 :: Show a => String -> a -> a
dbg1 = dbgAt 1 dbg1 = tracePrettyAt 1
dbg2 :: Show a => String -> a -> a dbg2 :: Show a => String -> a -> a
dbg2 = dbgAt 2 dbg2 = tracePrettyAt 2
dbg3 :: Show a => String -> a -> a dbg3 :: Show a => String -> a -> a
dbg3 = dbgAt 3 dbg3 = tracePrettyAt 3
dbg4 :: Show a => String -> a -> a dbg4 :: Show a => String -> a -> a
dbg4 = dbgAt 4 dbg4 = tracePrettyAt 4
dbg5 :: Show a => String -> a -> a dbg5 :: Show a => String -> a -> a
dbg5 = dbgAt 5 dbg5 = tracePrettyAt 5
dbg6 :: Show a => String -> a -> a dbg6 :: Show a => String -> a -> a
dbg6 = dbgAt 6 dbg6 = tracePrettyAt 6
dbg7 :: Show a => String -> a -> a dbg7 :: Show a => String -> a -> a
dbg7 = dbgAt 7 dbg7 = tracePrettyAt 7
dbg8 :: Show a => String -> a -> a dbg8 :: Show a => String -> a -> a
dbg8 = dbgAt 8 dbg8 = tracePrettyAt 8
dbg9 :: Show a => String -> a -> a dbg9 :: Show a => String -> a -> a
dbg9 = dbgAt 9 dbg9 = tracePrettyAt 9
-- | Print a message and a showable value to the console if the global -- | Convenience aliases for tracePrettyAtIO.
-- debug level is at or above the specified level. Uses unsafePerformIO. -- Like dbg, but convenient to insert in an IO monad.
dbgAt :: Show a => Int -> String -> a -> a dbgIO :: Show a => String -> a -> IO ()
dbgAt lvl = dbgppshow lvl dbgIO = tracePrettyAtIO 0
-- Could not deduce (a ~ ()) dbg1IO :: Show a => String -> a -> IO ()
-- from the context (Show a) dbg1IO = tracePrettyAtIO 1
-- bound by the type signature for
-- dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13-42
-- ‘a’ is a rigid type variable bound by
-- the type signature for dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13
-- Expected type: String -> a -> IO ()
-- Actual type: String -> a -> IO a
-- dbgAtM :: (Monad m, Show a) => Int -> String -> a -> m a
-- dbgAtM lvl lbl x = dbgAt lvl lbl x `seq` return x
-- XXX temporary:
dbgAtM :: Show a => Int -> String -> a -> IO ()
dbgAtM = dbgAtIO
dbgAtIO :: Show a => Int -> String -> a -> IO () dbg2IO :: Show a => String -> a -> IO ()
dbgAtIO lvl lbl x = dbgAt lvl lbl x `seq` return () dbg2IO = tracePrettyAtIO 2
dbg3IO :: Show a => String -> a -> IO ()
dbg3IO = tracePrettyAtIO 3
dbg4IO :: Show a => String -> a -> IO ()
dbg4IO = tracePrettyAtIO 4
dbg5IO :: Show a => String -> a -> IO ()
dbg5IO = tracePrettyAtIO 5
dbg6IO :: Show a => String -> a -> IO ()
dbg6IO = tracePrettyAtIO 6
dbg7IO :: Show a => String -> a -> IO ()
dbg7IO = tracePrettyAtIO 7
dbg8IO :: Show a => String -> a -> IO ()
dbg8IO = tracePrettyAtIO 8
dbg9IO :: Show a => String -> a -> IO ()
dbg9IO = tracePrettyAtIO 9
-- | Pretty-print a message and a showable value to the console if the debug level is at or above the specified level.
-- dbtAt 0 always prints. Otherwise, uses unsafePerformIO.
tracePrettyAt :: Show a => Int -> String -> a -> a
tracePrettyAt lvl = dbgppshow lvl
tracePrettyAtIO :: Show a => Int -> String -> a -> IO ()
tracePrettyAtIO lvl lbl x = tracePrettyAt lvl lbl x `seq` return ()
-- XXX
-- Could not deduce (a ~ ())
-- from the context (Show a)
-- bound by the type signature for
-- dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13-42
-- ‘a’ is a rigid type variable bound by
-- the type signature for dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13
-- Expected type: String -> a -> IO ()
-- Actual type: String -> a -> IO a
--
-- tracePrettyAtM :: (Monad m, Show a) => Int -> String -> a -> m a
-- tracePrettyAtM lvl lbl x = tracePrettyAt lvl lbl x `seq` return x
-- | print this string to the console before evaluating the expression, -- | print this string to the console before evaluating the expression,
-- if the global debug level is non-zero. Uses unsafePerformIO. -- if the global debug level is non-zero. Uses unsafePerformIO.
@ -168,7 +196,7 @@ dbgshow level
-- Values are displayed with ppShow, each field/constructor on its own line. -- Values are displayed with ppShow, each field/constructor on its own line.
dbgppshow :: Show a => Int -> String -> a -> a dbgppshow :: Show a => Int -> String -> a -> a
dbgppshow level dbgppshow level
| debugLevel < level = flip const | level > 0 && debugLevel < level = flip const
| otherwise = \s a -> let p = ppShow a | otherwise = \s a -> let p = ppShow a
ls = lines p ls = lines p
nlorspace | length ls > 1 = "\n" nlorspace | length ls > 1 = "\n"

8
hledger/Hledger/Cli/Accounts.hs
View File

@ -49,10 +49,10 @@ accounts :: CliOpts -> Journal -> IO ()
accounts CliOpts{reportopts_=ropts} j = do accounts CliOpts{reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
let q = queryFromOpts d ropts let q = queryFromOpts d ropts
nodepthq = dbg "nodepthq" $ filterQuery (not . queryIsDepth) q nodepthq = dbg1 "nodepthq" $ filterQuery (not . queryIsDepth) q
depth = dbg "depth" $ queryDepth $ filterQuery queryIsDepth q depth = dbg1 "depth" $ queryDepth $ filterQuery queryIsDepth q
ps = dbg "ps" $ journalPostings $ filterJournalPostings nodepthq j ps = dbg1 "ps" $ journalPostings $ filterJournalPostings nodepthq j
as = dbg "as" $ nub $ filter (not . null) $ map (clipAccountName depth) $ sort $ map paccount ps as = dbg1 "as" $ nub $ filter (not . null) $ map (clipAccountName depth) $ sort $ map paccount ps
as' | tree_ ropts = expandAccountNames as as' | tree_ ropts = expandAccountNames as
| otherwise = as | otherwise = as
render a | tree_ ropts = replicate (2 * (accountNameLevel a - 1)) ' ' ++ accountLeafName a render a | tree_ ropts = replicate (2 * (accountNameLevel a - 1)) ' ' ++ accountLeafName a

10
hledger/Hledger/Cli/Add.hs
View File

@ -241,11 +241,11 @@ accountWizard EntryState{..} = do
line $ green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def) line $ green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)
where where
canfinish = not (null esPostings) && postingsBalanced esPostings canfinish = not (null esPostings) && postingsBalanced esPostings
parseAccountOrDotOrNull _ _ "." = dbg $ Just "." -- . always signals end of txn parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "." -- . always signals end of txn
parseAccountOrDotOrNull "" True "" = dbg $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn parseAccountOrDotOrNull "" True "" = dbg1 $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn
parseAccountOrDotOrNull def@(_:_) _ "" = dbg $ Just def -- when there's a default, "" means use that parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg $ either (const Nothing) validateAccount $ runParser (accountnamep <* eof) (jContext esJournal) "" s -- otherwise, try to parse the input as an accountname parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) validateAccount $ runParser (accountnamep <* eof) (jContext esJournal) "" s -- otherwise, try to parse the input as an accountname
dbg = id -- strace dbg1 = id -- strace
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s | otherwise = Just s

2
hledger/Hledger/Cli/Balance.hs
View File

@ -434,7 +434,7 @@ periodBalanceReportAsText opts r@(MultiBalanceReport (colspans, items, (coltotal
++ (if row_total_ opts then [" Total"] else []) ++ (if row_total_ opts then [" Total"] else [])
++ (if average_ opts then ["Average"] else []) ++ (if average_ opts then ["Average"] else [])
items' | empty_ opts = items items' | empty_ opts = items
| otherwise = items -- dbg "2" $ filter (any (not . isZeroMixedAmount) . snd) $ dbg "1" items | otherwise = items -- dbg1 "2" $ filter (any (not . isZeroMixedAmount) . snd) $ dbg1 "1" items
accts = map renderacct items' accts = map renderacct items'
renderacct ((a,a',i),_,_,_) renderacct ((a,a',i),_,_,_)
| tree_ opts = replicate ((i-1)*2) ' ' ++ a' | tree_ opts = replicate ((i-1)*2) ' ' ++ a'

44
hledger/Hledger/Cli/Main.hs
View File

@ -199,15 +199,15 @@ main = do
isNullCommand = null rawcmd isNullCommand = null rawcmd
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args (argsbeforecmd, argsaftercmd') = break (==rawcmd) args
argsaftercmd = drop 1 argsaftercmd' argsaftercmd = drop 1 argsaftercmd'
dbgM :: Show a => String -> a -> IO () dbgIO :: Show a => String -> a -> IO ()
dbgM = dbgAtM 2 dbgIO = tracePrettyAtIO 2
dbgM "running" prognameandversion dbgIO "running" prognameandversion
dbgM "raw args" args dbgIO "raw args" args
dbgM "raw args rearranged for cmdargs" args' dbgIO "raw args rearranged for cmdargs" args'
dbgM "raw command is probably" rawcmd dbgIO "raw command is probably" rawcmd
dbgM "raw args before command" argsbeforecmd dbgIO "raw args before command" argsbeforecmd
dbgM "raw args after command" argsaftercmd dbgIO "raw args after command" argsaftercmd
-- Search PATH for add-ons, excluding any that match built-in names. -- Search PATH for add-ons, excluding any that match built-in names.
-- The precise addon names (including file extension) are used for command -- The precise addon names (including file extension) are used for command
@ -231,27 +231,27 @@ main = do
generalHelp = putStr $ showModeHelp $ mainmode addonDisplayNames generalHelp = putStr $ showModeHelp $ mainmode addonDisplayNames
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure
f `orShowHelp` mode = if hasHelp args then putStr (showModeHelp mode) else f f `orShowHelp` mode = if hasHelp args then putStr (showModeHelp mode) else f
dbgM "processed opts" opts dbgIO "processed opts" opts
dbgM "command matched" cmd dbgIO "command matched" cmd
dbgM "isNullCommand" isNullCommand dbgIO "isNullCommand" isNullCommand
dbgM "isInternalCommand" isInternalCommand dbgIO "isInternalCommand" isInternalCommand
dbgM "isExternalCommand" isExternalCommand dbgIO "isExternalCommand" isExternalCommand
dbgM "isBadCommand" isBadCommand dbgIO "isBadCommand" isBadCommand
d <- getCurrentDay d <- getCurrentDay
dbgM "date span from opts" (dateSpanFromOpts d $ reportopts_ opts) dbgIO "date span from opts" (dateSpanFromOpts d $ reportopts_ opts)
dbgM "interval from opts" (intervalFromOpts $ reportopts_ opts) dbgIO "interval from opts" (intervalFromOpts $ reportopts_ opts)
dbgM "query from opts & args" (queryFromOpts d $ reportopts_ opts) dbgIO "query from opts & args" (queryFromOpts d $ reportopts_ opts)
let let
runHledgerCommand runHledgerCommand
-- high priority flags and situations. --help should be highest priority. -- high priority flags and situations. --help should be highest priority.
| hasHelp argsbeforecmd = dbgM "" "--help before command, showing general help" >> generalHelp | hasHelp argsbeforecmd = dbgIO "" "--help before command, showing general help" >> generalHelp
| not (hasHelp argsaftercmd) && (hasVersion argsbeforecmd || (hasVersion argsaftercmd && isInternalCommand)) | not (hasHelp argsaftercmd) && (hasVersion argsbeforecmd || (hasVersion argsaftercmd && isInternalCommand))
= putStrLn prognameandversion = putStrLn prognameandversion
| not (hasHelp argsaftercmd) && (hasDetailedVersion argsbeforecmd || (hasDetailedVersion argsaftercmd && isInternalCommand)) | not (hasHelp argsaftercmd) && (hasDetailedVersion argsbeforecmd || (hasDetailedVersion argsaftercmd && isInternalCommand))
= putStrLn prognameanddetailedversion = putStrLn prognameanddetailedversion
-- \| (null externalcmd) && "binary-filename" `inRawOpts` rawopts = putStrLn $ binaryfilename progname -- \| (null externalcmd) && "binary-filename" `inRawOpts` rawopts = putStrLn $ binaryfilename progname
-- \| "--browse-args" `elem` args = System.Console.CmdArgs.Helper.execute "cmdargs-browser" mainmode' args >>= (putStr . show) -- \| "--browse-args" `elem` args = System.Console.CmdArgs.Helper.execute "cmdargs-browser" mainmode' args >>= (putStr . show)
| isNullCommand = dbgM "" "no command, showing general help" >> generalHelp | isNullCommand = dbgIO "" "no command, showing general help" >> generalHelp
| isBadCommand = badCommandError | isBadCommand = badCommandError
-- internal commands -- internal commands
@ -271,9 +271,9 @@ main = do
| isExternalCommand = do | isExternalCommand = do
let externalargs = argsbeforecmd ++ filter (not.(=="--")) argsaftercmd let externalargs = argsbeforecmd ++ filter (not.(=="--")) argsaftercmd
let shellcmd = printf "%s-%s %s" progname cmd (unwords' externalargs) :: String let shellcmd = printf "%s-%s %s" progname cmd (unwords' externalargs) :: String
dbgM "external command selected" cmd dbgIO "external command selected" cmd
dbgM "external command arguments" (map quoteIfNeeded externalargs) dbgIO "external command arguments" (map quoteIfNeeded externalargs)
dbgM "running shell command" shellcmd dbgIO "running shell command" shellcmd
system shellcmd >>= exitWith system shellcmd >>= exitWith
-- deprecated commands -- deprecated commands