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

lib: Do not call showAmount twice for every posting.

Browse Source 
For print -f examples/10000x10000x10.journal, this results in
- A 7.7% reduction in heap allocations, from 7.6GB to 7.1GB.
This commit is contained in:
Stephen Morgan 2021-03-18 16:11:19 +11:00 committed by Simon Michael
parent 7aa3d3e760
commit 7488140608
2 changed files with 100 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -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 "

118
hledger/Hledger/Cli/Commands/Register.hs
View File

@ -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