From 748814060825cdd420357625eea80d07e0945684 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Thu, 18 Mar 2021 16:11:19 +1100 Subject: [PATCH] lib: Do not call showAmount twice for every posting. For print -f examples/10000x10000x10.journal, this results in - A 7.7% reduction in heap allocations, from 7.6GB to 7.1GB. --- hledger-lib/Hledger/Data/Transaction.hs | 60 +++++++----- hledger/Hledger/Cli/Commands/Register.hs | 118 ++++++++++++----------- 2 files changed, 100 insertions(+), 78 deletions(-) diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 7e3bab950..e2a7dbaa2 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -75,6 +75,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day, fromGregorian) import qualified Data.Map as M +import Safe (maximumDef) import Hledger.Utils import Hledger.Data.Types @@ -218,9 +219,12 @@ renderCommentLines t = -- -- Posting amounts will be aligned with each other, starting about 4 columns -- beyond the widest account name (see postingAsLines for details). --- postingsAsLines :: Bool -> [Posting] -> [Text] -postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamounts ps) ps +postingsAsLines onelineamounts ps = concatMap first3 linesWithWidths + where + linesWithWidths = map (postingAsLines False onelineamounts maxacctwidth maxamtwidth) ps + maxacctwidth = maximumDef 0 $ map second3 linesWithWidths + maxamtwidth = maximumDef 0 $ map third3 linesWithWidths -- | Render one posting, on one or more lines, suitable for `print` output. -- There will be an indented account name, plus one or more of status flag, @@ -241,9 +245,10 @@ postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamoun -- increased if needed to match the posting with the longest account name. -- This is used to align the amounts of a transaction's postings. -- -postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [Text] -postingAsLines elideamount onelineamounts pstoalignwith p = - concatMap (++ newlinecomments) postingblocks +-- Also returns the account width and amount width used. +postingAsLines :: Bool -> Bool -> Int -> Int -> Posting -> ([Text], Int, Int) +postingAsLines elideamount onelineamounts acctwidth amtwidth p = + (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) where -- This needs to be converted to strict Text in order to strip trailing -- spaces. This adds a small amount of inefficiency, and the only difference @@ -253,30 +258,35 @@ postingAsLines elideamount onelineamounts pstoalignwith p = postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ render [ textCell BottomLeft statusandaccount , textCell BottomLeft " " - , Cell BottomLeft [amt] + , Cell BottomLeft [pad amt] , Cell BottomLeft [assertion] , textCell BottomLeft samelinecomment ] | amt <- shownAmounts] render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header + pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt + where w = max 12 amtwidth - wbWidth amt -- min. 12 for backwards compatibility + assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p - statusandaccount = lineIndent . fitText (Just $ minwidth) Nothing False True $ pstatusandacct p - where - -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned - minwidth = maximum $ map ((2+) . textWidth . pacctstr) pstoalignwith - pstatusandacct p' = pstatusprefix p' <> pacctstr p' - pstatusprefix p' = case pstatus p' of - Unmarked -> "" - s -> T.pack (show s) <> " " - pacctstr p' = showAccountName Nothing (ptype p') (paccount p') + -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned + statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p + thisacctwidth = textWidth $ pacctstr p + + pacctstr p' = showAccountName Nothing (ptype p') (paccount p') + pstatusandacct p' = pstatusprefix p' <> pacctstr p' + pstatusprefix p' = case pstatus p' of + Unmarked -> "" + s -> T.pack (show s) <> " " -- currently prices are considered part of the amount string when right-aligning amounts + -- Since we will usually be calling this function with the knot tied between + -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on + -- amtwidth at all. shownAmounts | elideamount || null (amounts $ pamount p) = [mempty] | otherwise = showAmountsLinesB displayopts . amounts $ pamount p - where - displayopts = noColour{displayOneLine=onelineamounts, displayMinWidth = Just amtwidth} - amtwidth = maximum $ 12 : map (wbWidth . showAmountsB displayopts{displayMinWidth=Nothing} . amounts . pamount) pstoalignwith -- min. 12 for backwards compatibility + where displayopts = noColour{displayOneLine=onelineamounts} + thisamtwidth = maximumDef 0 $ map wbWidth shownAmounts (samelinecomment, newlinecomments) = case renderCommentLines (pcomment p) of [] -> ("",[]) @@ -306,9 +316,11 @@ showBalanceAssertion BalanceAssertion{..} = -- | Render a posting, at the appropriate width for aligning with -- its siblings if any. Used by the rewrite command. showPostingLines :: Posting -> [Text] -showPostingLines p = postingAsLines False False ps p where - ps | Just t <- ptransaction p = tpostings t - | otherwise = [p] +showPostingLines p = first3 $ postingAsLines False False maxacctwidth maxamtwidth p + where + linesWithWidths = map (postingAsLines False False maxacctwidth maxamtwidth) . maybe [p] tpostings $ ptransaction p + maxacctwidth = maximumDef 0 $ map second3 linesWithWidths + maxamtwidth = maximumDef 0 $ map third3 linesWithWidths -- | Prepend a suitable indent for a posting (or transaction/posting comment) line. lineIndent :: Text -> Text @@ -642,8 +654,8 @@ tests_Transaction :: TestTree tests_Transaction = tests "Transaction" [ - tests "postingAsLines" [ - test "null posting" $ postingAsLines False False [posting] posting @?= [""] + tests "showPostingLines" [ + test "null posting" $ showPostingLines posting @?= [""] , test "non-null posting" $ let p = posting @@ -654,7 +666,7 @@ tests_Transaction = , ptype = RegularPosting , ptags = [("ptag1", "val1"), ("ptag2", "val2")] } - in postingAsLines False False [p] p @?= + in showPostingLines p @?= [ " * a $1.00 ; pcomment1" , " ; pcomment2" , " ; tag3: val3 " diff --git a/hledger/Hledger/Cli/Commands/Register.hs b/hledger/Hledger/Cli/Commands/Register.hs index 511454f0e..326dfc6bd 100644 --- a/hledger/Hledger/Cli/Commands/Register.hs +++ b/hledger/Hledger/Cli/Commands/Register.hs @@ -28,9 +28,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import System.Console.CmdArgs.Explicit (flagNone, flagReq) -import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) +import Safe (maximumDef) import Hledger +import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) import Hledger.Cli.CliOptions import Hledger.Cli.Utils import Text.Tabular (Header(..), Properties(..)) @@ -97,15 +98,18 @@ postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal -- | Render a register report as plain text suitable for console output. postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text -postingsReportAsText opts items = - TB.toLazyText . unlinesB $ - map (postingsReportItemAsText opts amtwidth balwidth) items +postingsReportAsText opts items = TB.toLazyText $ foldMap first3 linesWithWidths where - amtwidth = maximumStrict $ map (wbWidth . showAmt . itemamt) items - balwidth = maximumStrict $ map (wbWidth . showAmt . itembal) items - itemamt (_,_,_,Posting{pamount=a},_) = a - itembal (_,_,_,_,a) = a - showAmt = showMixedAmountB noColour{displayMinWidth=Just 12} + linesWithWidths = map (postingsReportItemAsText opts amtwidth balwidth) items + -- Tying this knot seems like it will save work, but ends up creating a big + -- space leak. Can we fix that leak without recalculating everything? + -- amtwidth = maximum $ 12 : map second3 linesWithWidths + -- balwidth = maximum $ 12 : map third3 linesWithWidths + amtwidth = maximumStrict $ 12 : widths (map itemamt items) + balwidth = maximumStrict $ 12 : widths (map itembal items) + widths = map wbWidth . concatMap (showAmountsLinesB noPrice) + itemamt (_,_,_,Posting{pamount=a},_) = amounts a + itembal (_,_,_,_,a) = amounts a -- | Render one register report line item as plain text. Layout is like so: -- @ @@ -129,62 +133,68 @@ postingsReportAsText opts items = -- has multiple commodities. Does not yet support formatting control -- like balance reports. -- -postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> TB.Builder +-- Also returns the natural width (without padding) of the amount and balance +-- fields. +postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> (TB.Builder, Int, Int) postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, menddate, mdesc, p, b) = - render + (table <> TB.singleton '\n', thisamtwidth, thisbalwidth) + where + table = renderRowB def{tableBorders=False, borderSpaces=False} . Group NoLine $ map Header [ textCell TopLeft $ fitText (Just datewidth) (Just datewidth) True True date , spacerCell , textCell TopLeft $ fitText (Just descwidth) (Just descwidth) True True desc , spacerCell2 , textCell TopLeft $ fitText (Just acctwidth) (Just acctwidth) True True acct , spacerCell2 - , Cell TopRight amt + , Cell TopRight $ map (pad amtwidth) amt , spacerCell2 - , Cell BottomRight bal + , Cell BottomRight $ map (pad balwidth) bal ] - where - render = renderRowB def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header - spacerCell = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] - spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString " ") 2] - -- calculate widths - (totalwidth,mdescwidth) = registerWidthsFromOpts opts - (datewidth, date) = case (mdate,menddate) of - (Just _, Just _) -> (21, showDateSpan (DateSpan mdate menddate)) - (Nothing, Just _) -> (21, "") - (Just d, Nothing) -> (10, showDate d) - _ -> (10, "") - (amtwidth, balwidth) - | shortfall <= 0 = (preferredamtwidth, preferredbalwidth) - | otherwise = (adjustedamtwidth, adjustedbalwidth) - where - mincolwidth = 2 -- columns always show at least an ellipsis - maxamtswidth = max 0 (totalwidth - (datewidth + 1 + mincolwidth + 2 + mincolwidth + 2 + 2)) - shortfall = (preferredamtwidth + preferredbalwidth) - maxamtswidth - amtwidthproportion = fromIntegral preferredamtwidth / fromIntegral (preferredamtwidth + preferredbalwidth) - adjustedamtwidth = round $ amtwidthproportion * fromIntegral maxamtswidth - adjustedbalwidth = maxamtswidth - adjustedamtwidth + spacerCell = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] + spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString " ") 2] + pad fullwidth amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt + where w = fullwidth - wbWidth amt + -- calculate widths + (totalwidth,mdescwidth) = registerWidthsFromOpts opts + (datewidth, date) = case (mdate,menddate) of + (Just _, Just _) -> (21, showDateSpan (DateSpan mdate menddate)) + (Nothing, Just _) -> (21, "") + (Just d, Nothing) -> (10, showDate d) + _ -> (10, "") + (amtwidth, balwidth) + | shortfall <= 0 = (preferredamtwidth, preferredbalwidth) + | otherwise = (adjustedamtwidth, adjustedbalwidth) + where + mincolwidth = 2 -- columns always show at least an ellipsis + maxamtswidth = max 0 (totalwidth - (datewidth + 1 + mincolwidth + 2 + mincolwidth + 2 + 2)) + shortfall = (preferredamtwidth + preferredbalwidth) - maxamtswidth + amtwidthproportion = fromIntegral preferredamtwidth / fromIntegral (preferredamtwidth + preferredbalwidth) + adjustedamtwidth = round $ amtwidthproportion * fromIntegral maxamtswidth + adjustedbalwidth = maxamtswidth - adjustedamtwidth - remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth) - (descwidth, acctwidth) - | hasinterval = (0, remaining - 2) - | otherwise = (w, remaining - 2 - w) - where - hasinterval = isJust menddate - w = fromMaybe ((remaining - 2) `div` 2) mdescwidth + remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth) + (descwidth, acctwidth) + | hasinterval = (0, remaining - 2) + | otherwise = (w, remaining - 2 - w) + where + hasinterval = isJust menddate + w = fromMaybe ((remaining - 2) `div` 2) mdescwidth - -- gather content - desc = fromMaybe "" mdesc - acct = parenthesise . elideAccountName awidth $ paccount p - where - (parenthesise, awidth) = - case ptype p of - BalancedVirtualPosting -> (\s -> wrap "[" "]" s, acctwidth-2) - VirtualPosting -> (\s -> wrap "(" ")" s, acctwidth-2) - _ -> (id,acctwidth) - wrap a b x = a <> x <> b - amt = showAmountsLinesB (dopts amtwidth) . (\x -> if null x then [nullamt] else x) . amounts $ pamount p - bal = showAmountsLinesB (dopts balwidth) $ amounts b - dopts w = noPrice{displayColour=color_ . rsOpts $ reportspec_ opts, displayMinWidth=Just w, displayMaxWidth=Just w} + -- gather content + desc = fromMaybe "" mdesc + acct = parenthesise . elideAccountName awidth $ paccount p + where + (parenthesise, awidth) = case ptype p of + BalancedVirtualPosting -> (wrap "[" "]", acctwidth-2) + VirtualPosting -> (wrap "(" ")", acctwidth-2) + _ -> (id,acctwidth) + amt = showAmountsLinesB dopts . (\x -> if null x then [nullamt] else x) . amounts $ pamount p + bal = showAmountsLinesB dopts $ amounts b + dopts = noPrice{displayColour=color_ . rsOpts $ reportspec_ opts} + -- Since this will usually be called with the knot tied between this(amt|bal)width and + -- preferred(amt|bal)width, make sure the former do not depend on the latter to avoid loops. + thisamtwidth = maximumDef 0 $ map wbWidth amt + thisbalwidth = maximumDef 0 $ map wbWidth bal -- tests