bal: option to view one commodity per row

This adds the `--commodity-column` option that displays each commodity
on a separate line and the commodities themselves as a separate column.
The initial design considerations are at
simonmichael.hledger.issues.1559

The single-period balance report with `--commodity-column` does not
interoperate with custom formats.
This commit is contained in:
Lawrence Wu 2021-07-22 13:04:59 -05:00 committed by Simon Michael
parent ed7ee7a445
commit f3c07144a8
8 changed files with 187 additions and 74 deletions

View File

@ -152,7 +152,7 @@ import Data.Foldable (toList)
import Data.List (find, foldl', intercalate, intersperse, mapAccumL, partition) import Data.List (find, foldl', intercalate, intersperse, mapAccumL, partition)
import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing, isJust)
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
@ -175,6 +175,9 @@ data AmountDisplayOpts = AmountDisplayOpts
, displayOneLine :: Bool -- ^ Whether to display on one line. , displayOneLine :: Bool -- ^ Whether to display on one line.
, displayMinWidth :: Maybe Int -- ^ Minimum width to pad to , displayMinWidth :: Maybe Int -- ^ Minimum width to pad to
, displayMaxWidth :: Maybe Int -- ^ Maximum width to clip to , displayMaxWidth :: Maybe Int -- ^ Maximum width to clip to
-- | Display amounts in this order (without the commodity symbol) and display
-- a 0 in case a corresponding commodity does not exist
, displayOrder :: Maybe [CommoditySymbol]
} deriving (Show) } deriving (Show)
-- | Display Amount and MixedAmount with no colour. -- | Display Amount and MixedAmount with no colour.
@ -186,8 +189,9 @@ noColour = AmountDisplayOpts { displayPrice = True
, displayColour = False , displayColour = False
, displayZeroCommodity = False , displayZeroCommodity = False
, displayOneLine = False , displayOneLine = False
, displayMinWidth = Nothing , displayMinWidth = Just 0
, displayMaxWidth = Nothing , displayMaxWidth = Nothing
, displayOrder = Nothing
} }
-- | Display Amount and MixedAmount with no prices. -- | Display Amount and MixedAmount with no prices.
@ -429,14 +433,15 @@ showAmountB :: AmountDisplayOpts -> Amount -> WideBuilder
showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB _ Amount{acommodity="AUTO"} = mempty
showAmountB opts a@Amount{astyle=style} = showAmountB opts a@Amount{astyle=style} =
color $ case ascommodityside style of color $ case ascommodityside style of
L -> c' <> space <> quantity' <> price L -> showC c' space <> quantity' <> price
R -> quantity' <> space <> c' <> price R -> quantity' <> showC space c' <> price
where where
quantity = showamountquantity a quantity = showamountquantity a
(quantity',c) | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1,"") (quantity',c) | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1,"")
| otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a)
space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty
c' = WideBuilder (TB.fromText c) (textWidth c) c' = WideBuilder (TB.fromText c) (textWidth c)
showC l r = if isJust (displayOrder opts) then mempty else l <> r
price = if displayPrice opts then showAmountPrice a else mempty price = if displayPrice opts then showAmountPrice a else mempty
color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id
@ -820,13 +825,16 @@ showMixedAmountLinesB :: AmountDisplayOpts -> MixedAmount -> [WideBuilder]
showMixedAmountLinesB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma = showMixedAmountLinesB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma =
map (adBuilder . pad) elided map (adBuilder . pad) elided
where where
astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . amounts $ astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $
if displayPrice opts then ma else mixedAmountStripPrices ma if displayPrice opts then ma else mixedAmountStripPrices ma
sep = WideBuilder (TB.singleton '\n') 0 sep = WideBuilder (TB.singleton '\n') 0
width = maximum $ fromMaybe 0 mmin : map (wbWidth . adBuilder) elided width = maximum $ map (wbWidth . adBuilder) elided
pad amt = amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt } pad amt
where w = width - wbWidth (adBuilder amt) | Just mw <- mmin =
let w = (max width mw) - wbWidth (adBuilder amt)
in amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt }
| otherwise = amt
elided = maybe id elideTo mmax astrs elided = maybe id elideTo mmax astrs
elideTo m xs = maybeAppend elisionStr short elideTo m xs = maybeAppend elisionStr short
@ -843,7 +851,7 @@ showMixedAmountOneLineB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWi
. max width $ fromMaybe 0 mmin . max width $ fromMaybe 0 mmin
where where
width = maybe 0 adTotal $ lastMay elided width = maybe 0 adTotal $ lastMay elided
astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . amounts $ astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $
if displayPrice opts then ma else mixedAmountStripPrices ma if displayPrice opts then ma else mixedAmountStripPrices ma
sep = WideBuilder (TB.fromString ", ") 2 sep = WideBuilder (TB.fromString ", ") 2
n = length astrs n = length astrs
@ -866,6 +874,15 @@ showMixedAmountOneLineB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWi
-- Add the elision strings (if any) to each amount -- Add the elision strings (if any) to each amount
withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0] withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0]
orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount]
orderedAmounts AmountDisplayOpts{displayOrder=ord} ma
| Just cs <- ord = fmap pad cs
| otherwise = as
where
as = amounts ma
pad c = fromMaybe (amountWithCommodity c nullamt) . find ((==) c . acommodity) $ as
data AmountDisplay = AmountDisplay data AmountDisplay = AmountDisplay
{ adBuilder :: !WideBuilder -- ^ String representation of the Amount { adBuilder :: !WideBuilder -- ^ String representation of the Amount
, adTotal :: !Int -- ^ Cumulative length of MixedAmount this Amount is part of, , adTotal :: !Int -- ^ Cumulative length of MixedAmount this Amount is part of,

View File

@ -136,7 +136,7 @@ formatfieldp = do
char '(' char '('
f <- fieldp f <- fieldp
char ')' char ')'
return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f return $ FormatField (isJust leftJustified) (parseDec minWidth <|> Just 0) (parseDec maxWidth) f
where where
parseDec s = case s of parseDec s = case s of
Just text -> Just m where ((m,_):_) = readDec text Just text -> Just m where ((m,_):_) = readDec text
@ -175,20 +175,20 @@ tests_StringFormat = tests "StringFormat" [
in tests "parseStringFormat" [ in tests "parseStringFormat" [
"" `gives` (defaultStringFormatStyle []) "" `gives` (defaultStringFormatStyle [])
, "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"]) , "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"])
, "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField]) , "%(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing DescriptionField])
, "%(total)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField]) , "%(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing TotalField])
-- TODO -- TODO
-- , "^%(total)" `gives` (TopAligned [FormatField False Nothing Nothing TotalField]) -- , "^%(total)" `gives` (TopAligned [FormatField False Nothing Nothing TotalField])
-- , "_%(total)" `gives` (BottomAligned [FormatField False Nothing Nothing TotalField]) -- , "_%(total)" `gives` (BottomAligned [FormatField False Nothing Nothing TotalField])
-- , ",%(total)" `gives` (OneLine [FormatField False Nothing Nothing TotalField]) -- , ",%(total)" `gives` (OneLine [FormatField False Nothing Nothing TotalField])
, "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]) , "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False (Just 0) Nothing DescriptionField, FormatLiteral "!"])
, "%-(date)" `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField]) , "%-(date)" `gives` (defaultStringFormatStyle [FormatField True (Just 0) Nothing DescriptionField])
, "%20(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField]) , "%20(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])
, "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField]) , "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) (Just 10) DescriptionField])
, "%20.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField]) , "%20.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])
, "%20(account) %.10(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField , "%20(account) %.10(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField
,FormatLiteral " " ,FormatLiteral " "
,FormatField False Nothing (Just 10) TotalField ,FormatField False (Just 0) (Just 10) TotalField
]) ])
, test "newline not parsed" $ assertLeft $ parseStringFormat "\n" , test "newline not parsed" $ assertLeft $ parseStringFormat "\n"
] ]

View File

@ -156,6 +156,7 @@ data ReportOpts = ReportOpts {
-- whether stdout is an interactive terminal, and the value of -- whether stdout is an interactive terminal, and the value of
-- TERM and existence of NO_COLOR environment variables. -- TERM and existence of NO_COLOR environment variables.
,transpose_ :: Bool ,transpose_ :: Bool
,commodity_column_:: Bool
} deriving (Show) } deriving (Show)
instance Default ReportOpts where def = defreportopts instance Default ReportOpts where def = defreportopts
@ -193,6 +194,7 @@ defreportopts = ReportOpts
, normalbalance_ = Nothing , normalbalance_ = Nothing
, color_ = False , color_ = False
, transpose_ = False , transpose_ = False
, commodity_column_ = False
} }
-- | Generate a ReportOpts from raw command-line input, given a day. -- | Generate a ReportOpts from raw command-line input, given a day.
@ -243,6 +245,7 @@ rawOptsToReportOpts d rawopts =
,pretty_tables_ = boolopt "pretty-tables" rawopts ,pretty_tables_ = boolopt "pretty-tables" rawopts
,color_ = useColorOnStdout -- a lower-level helper ,color_ = useColorOnStdout -- a lower-level helper
,transpose_ = boolopt "transpose" rawopts ,transpose_ = boolopt "transpose" rawopts
,commodity_column_= boolopt "commodity-column" rawopts
} }
-- | The result of successfully parsing a ReportOpts on a particular -- | The result of successfully parsing a ReportOpts on a particular

View File

@ -41,6 +41,7 @@ module Hledger.Utils.Text
-- * wide-character-aware layout -- * wide-character-aware layout
WideBuilder(..), WideBuilder(..),
wbToText, wbToText,
wbFromText,
wbUnpack, wbUnpack,
textWidth, textWidth,
textTakeWidth, textTakeWidth,
@ -61,7 +62,7 @@ import qualified Data.Text.Lazy.Builder as TB
import Hledger.Utils.Test ((@?=), test, tests) import Hledger.Utils.Test ((@?=), test, tests)
import Text.Tabular.AsciiWide import Text.Tabular.AsciiWide
(Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell) (Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell)
import Text.WideString (WideBuilder(..), wbToText, wbUnpack, charWidth, textWidth) import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack, charWidth, textWidth)
-- lowercase, uppercase :: String -> String -- lowercase, uppercase :: String -> String

View File

@ -10,13 +10,16 @@ module Text.Tabular.AsciiWide
, render , render
, renderTable , renderTable
, renderTableB , renderTableB
, renderTableByRowsB
, renderRow , renderRow
, renderRowB , renderRowB
, renderColumns
, Cell(..) , Cell(..)
, Align(..) , Align(..)
, emptyCell , emptyCell
, textCell , textCell
, textsCell
, cellWidth , cellWidth
) where ) where
@ -30,7 +33,7 @@ import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText) import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText)
import Safe (maximumMay) import Safe (maximumMay)
import Text.Tabular import Text.Tabular
import Text.WideString (WideBuilder(..), textWidth) import Text.WideString (WideBuilder(..), wbFromText, textWidth)
-- | The options to use for rendering a table. -- | The options to use for rendering a table.
@ -60,6 +63,10 @@ emptyCell = Cell TopRight []
textCell :: Align -> Text -> Cell textCell :: Align -> Text -> Cell
textCell a x = Cell a . map (\x -> WideBuilder (fromText x) (textWidth x)) $ if T.null x then [""] else T.lines x textCell a x = Cell a . map (\x -> WideBuilder (fromText x) (textWidth x)) $ if T.null x then [""] else T.lines x
-- | Create a multi-line cell from the given contents with its natural width.
textsCell :: Align -> [Text] -> Cell
textsCell a = Cell a . fmap wbFromText
-- | Return the width of a Cell. -- | Return the width of a Cell.
cellWidth :: Cell -> Int cellWidth :: Cell -> Int
cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map wbWidth xs cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map wbWidth xs
@ -86,20 +93,31 @@ renderTableB :: TableOpts -- ^ Options controlling Table rendering
-> (a -> Cell) -- ^ Function determining the string and width of a cell -> (a -> Cell) -- ^ Function determining the string and width of a cell
-> Table rh ch a -> Table rh ch a
-> Builder -> Builder
renderTableB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) = renderTableB topts fr fc f = renderTableByRowsB topts (fmap fc) (\(rh, as) -> (fr rh, fmap f as))
-- | A version of renderTable that operates on rows (including the 'row' of
-- column headers) and returns the underlying Builder.
renderTableByRowsB :: TableOpts -- ^ Options controlling Table rendering
-> ([ch] -> [Cell]) -- ^ Rendering function for column headers
-> ((rh, [a]) -> (Cell, [Cell])) -- ^ Rendering function for row and row header
-> Table rh ch a
-> Builder
renderTableByRowsB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fc f (Table rh ch cells) =
unlinesB . addBorders $ unlinesB . addBorders $
renderColumns topts sizes ch2 renderColumns topts sizes ch2
: bar VM DoubleLine -- +======================================+ : bar VM DoubleLine -- +======================================+
: renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders) : renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders)
where where
renderR :: ([Cell], Cell) -> Builder
renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine
[ Header h [ Header h
, fmap fst $ zipHeader emptyCell cs colHeaders , fmap fst $ zipHeader emptyCell cs colHeaders
] ]
rowHeaders = fmap fr rh rows = unzip . fmap f $ zip (headerContents rh) cells
colHeaders = fmap fc ch rowHeaders = fmap fst $ zipHeader emptyCell (fst rows) rh
cellContents = map (map f) cells colHeaders = fmap fst $ zipHeader emptyCell (fc $ headerContents ch) ch
cellContents = snd rows
-- ch2 and cell2 include the row and column labels -- ch2 and cell2 include the row and column labels
ch2 = Group DoubleLine [Header emptyCell, colHeaders] ch2 = Group DoubleLine [Header emptyCell, colHeaders]
@ -162,6 +180,7 @@ renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=s
padCell (w, Cell TopRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls padCell (w, Cell TopRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls
padCell (w, Cell BottomRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls padCell (w, Cell BottomRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls
-- Pad each cell to have the same number of lines -- Pad each cell to have the same number of lines
padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) mempty padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) mempty
padRow (Cell TopRight ls) = Cell TopRight $ ls ++ replicate (nLines - length ls) mempty padRow (Cell TopRight ls) = Cell TopRight $ ls ++ replicate (nLines - length ls) mempty

View File

@ -8,7 +8,8 @@ module Text.WideString (
-- * Text Builders which keep track of length -- * Text Builders which keep track of length
WideBuilder(..), WideBuilder(..),
wbUnpack, wbUnpack,
wbToText wbToText,
wbFromText
) where ) where
import Data.Text (Text) import Data.Text (Text)
@ -33,6 +34,10 @@ instance Monoid WideBuilder where
wbToText :: WideBuilder -> Text wbToText :: WideBuilder -> Text
wbToText = TL.toStrict . TB.toLazyText . wbBuilder wbToText = TL.toStrict . TB.toLazyText . wbBuilder
-- | Convert a WideBuilder to a strict Text.
wbFromText :: Text -> WideBuilder
wbFromText t = WideBuilder (TB.fromText t) (textWidth t)
-- | Convert a WideBuilder to a String. -- | Convert a WideBuilder to a String.
wbUnpack :: WideBuilder -> String wbUnpack :: WideBuilder -> String
wbUnpack = TL.unpack . TB.toLazyText . wbBuilder wbUnpack = TL.unpack . TB.toLazyText . wbBuilder

View File

@ -244,6 +244,7 @@ module Hledger.Cli.Commands.Balance (
balancemode balancemode
,balance ,balance
,balanceReportAsText ,balanceReportAsText
,balanceReportAsCsv
,balanceReportItemAsText ,balanceReportItemAsText
,multiBalanceReportAsText ,multiBalanceReportAsText
,multiBalanceReportAsCsv ,multiBalanceReportAsCsv
@ -255,14 +256,17 @@ module Hledger.Cli.Commands.Balance (
) where ) where
import Data.Default (def) import Data.Default (def)
import Data.List (intersperse, transpose) import Data.List (intersperse, transpose, foldl', transpose)
import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (fromMaybe)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
import Data.Time (fromGregorian) import Data.Time (fromGregorian)
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
import Lucid as L import Lucid as L
import Safe (headMay, maximumMay)
import Text.Tabular.AsciiWide as Tab import Text.Tabular.AsciiWide as Tab
import Hledger import Hledger
@ -306,6 +310,8 @@ balancemode = hledgerCommandMode
,flagNone ["percent", "%"] (setboolopt "percent") "express values in percentage of each column's total" ,flagNone ["percent", "%"] (setboolopt "percent") "express values in percentage of each column's total"
,flagNone ["invert"] (setboolopt "invert") "display all amounts with reversed sign" ,flagNone ["invert"] (setboolopt "invert") "display all amounts with reversed sign"
,flagNone ["transpose"] (setboolopt "transpose") "transpose rows and columns" ,flagNone ["transpose"] (setboolopt "transpose") "transpose rows and columns"
,flagNone ["commodity-column"] (setboolopt "commodity-column")
"shows each commodity in its own automatically-generated subaccount, for tidier reports"
,outputFormatFlag ["txt","html","csv","json"] ,outputFormatFlag ["txt","html","csv","json"]
,outputFileFlag ,outputFileFlag
] ]
@ -385,31 +391,65 @@ balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ of
-- | Render a single-column balance report as CSV. -- | Render a single-column balance report as CSV.
balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV
balanceReportAsCsv opts (items, total) = balanceReportAsCsv opts (items, total) =
["account","balance"] : ("account" : ((if commodity_column_ opts then (:) "commodity" else id) $ "balance" : []))
[[accountNameDrop (drop_ opts) a, wbToText $ showMixedAmountB (balanceOpts False opts) b] | (a, _, _, b) <- items] : (concatMap (\(a, _, _, b) -> rows a b) items)
++ ++ if no_total_ opts then [] else rows "total" total
if no_total_ opts where
then [] rows :: AccountName -> MixedAmount -> [[T.Text]]
else [["total", wbToText $ showMixedAmountB (balanceOpts False opts) total]] rows name ma
| commodity_column_ opts =
fmap (\(k, a) -> [showName name, k, renderAmount . mixedAmount . amountStripPrices $ a])
. M.toList . foldl' sumAmounts mempty . amounts $ ma
| otherwise = [[showName name, renderAmount ma]]
showName = accountNameDrop (drop_ opts)
renderAmount amt = wbToText $ showMixedAmountB bopts amt
where bopts = (balanceOpts False opts){displayOrder = order}
order = if commodity_column_ opts then Just (commodities [amt]) else Nothing
sumAmounts mp am = M.insertWith (+) (acommodity am) am mp
-- | Render a single-column balance report as plain text. -- | Render a single-column balance report as plain text.
balanceReportAsText :: ReportOpts -> BalanceReport -> TB.Builder balanceReportAsText :: ReportOpts -> BalanceReport -> TB.Builder
balanceReportAsText opts ((items, total)) = balanceReportAsText opts ((items, total))
unlinesB lines | not (commodity_column_ opts) =
<> unlinesB (if no_total_ opts then [] else [overline, totalLines]) unlinesB lines
<> unlinesB (if no_total_ opts then [] else [overline, totalLines])
| iscustom = error' "Custom format not supported with --commodity-column" -- PARTIAL:
| otherwise = balanceReportAsText' opts ((items, total))
where where
(lines, sizes) = unzip $ map (balanceReportItemAsText opts) items (lines, sizes) = unzip $ map (balanceReportItemAsText opts) items
-- abuse renderBalanceReportItem to render the total with similar format -- abuse renderBalanceReportItem to render the total with similar format
(totalLines, _) = renderBalanceReportItem opts ("",0,total) (totalLines, _) = renderBalanceReportItem opts ("",0,total)
-- with a custom format, extend the line to the full report width; -- with a custom format, extend the line to the full report width;
-- otherwise show the usual 20-char line for compatibility -- otherwise show the usual 20-char line for compatibility
overlinewidth = case format_ opts of iscustom = case format_ opts of
OneLine ((FormatField _ _ _ TotalField):_) -> 20 OneLine ((FormatField _ _ _ TotalField):_) -> False
TopAligned ((FormatField _ _ _ TotalField):_) -> 20 TopAligned ((FormatField _ _ _ TotalField):_) -> False
BottomAligned ((FormatField _ _ _ TotalField):_) -> 20 BottomAligned ((FormatField _ _ _ TotalField):_) -> False
_ -> sum (map maximum' $ transpose sizes) _ -> True
overlinewidth = if iscustom then sum (map maximum' $ transpose sizes) else 20
overline = TB.fromText $ T.replicate overlinewidth "-" overline = TB.fromText $ T.replicate overlinewidth "-"
-- | Render a single-column balance report as plain text in commodity-column mode
balanceReportAsText' :: ReportOpts -> BalanceReport -> TB.Builder
balanceReportAsText' opts ((items, total)) =
unlinesB . fmap (renderColumns def{tableBorders=False} sizes . Tab.Group NoLine . fmap Header) $
lines ++ concat [[[overline], totalline] | not (no_total_ opts)]
where
render (_, acctname, depth, amt) =
[ Cell TopRight damts
, Cell TopLeft (fmap wbFromText cs)
, Cell TopLeft (replicate (length damts - 1) mempty ++ [wbFromText dispname]) ]
where dopts = (balanceOpts True opts){displayOrder=Just cs}
cs = commodities [amt]
dispname = T.replicate ((depth - 1) * 2) " " <> acctname
damts = showMixedAmountLinesB dopts amt
lines = fmap render items
totalline = render ("", "", 0, total)
sizes = fmap (fromMaybe 0 . maximumMay . map cellWidth) $
transpose ([totalline | not (no_total_ opts)] ++ lines)
overline = Cell TopLeft . pure . wbFromText . flip T.replicate "-" . fromMaybe 0 $ headMay sizes
{- {-
:r :r
This implementation turned out to be a bit convoluted but implements the following algorithm for formatting: This implementation turned out to be a bit convoluted but implements the following algorithm for formatting:
@ -468,56 +508,64 @@ renderComponent topaligned opts (acctname, depth, total) (FormatField ljust mmin
-- The CSV will always include the initial headings row, -- The CSV will always include the initial headings row,
-- and will include the final totals row unless --no-total is set. -- and will include the final totals row unless --no-total is set.
multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV
multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} multiBalanceReportAsCsv opts@ReportOpts{..} =
(PeriodicReport colspans items (PeriodicReportRow _ coltotals tot avg)) = (if transpose_ then transpose else id) . uncurry (++) . multiBalanceReportAsCsv' opts
maybetranspose $
("account" : map showDateSpan colspans multiBalanceReportAsCsv' :: ReportOpts -> MultiBalanceReport -> (CSV, CSV)
multiBalanceReportAsCsv' opts@ReportOpts{..}
(PeriodicReport colspans items tr) =
flip (,) totalrows $
("account" : ["commodity" | commodity_column_] ++ map showDateSpan colspans
++ ["total" | row_total_] ++ ["total" | row_total_]
++ ["average" | average_] ++ ["average" | average_]
) : ) :
[accountNameDrop (drop_ opts) (displayFull a) : concatMap (rowAsTexts (accountNameDrop drop_ . prrFullName)) items
map (wbToText . showMixedAmountB (balanceOpts False opts))
(amts
++ [rowtot | row_total_]
++ [rowavg | average_])
| PeriodicReportRow a amts rowtot rowavg <- items]
++
if no_total_ opts
then []
else ["total" :
map (wbToText . showMixedAmountB (balanceOpts False opts)) (
coltotals
++ [tot | row_total_]
++ [avg | average_]
)]
where where
maybetranspose | transpose_ opts = transpose rowAsTexts render row@(PeriodicReportRow _ as rowtot rowavg)
| otherwise = id | not commodity_column_ = [render row : fmap (wbToText . showMixedAmountB bopts) all]
| otherwise =
joinNames . zipWith (:) cs -- add symbols and names
. transpose -- each row becomes a list of Text quantities
. fmap (fmap wbToText . showMixedAmountLinesB bopts{displayOrder=Just cs, displayMinWidth=Nothing})
$ all
where
bopts = balanceOpts False opts
cs = commodities $ rowtot : rowavg : as
all = as
++ [rowtot | row_total_]
++ [rowavg | average_]
joinNames = fmap ((:) (render row))
totalrows :: [[T.Text]]
totalrows
| no_total_ = mempty
| otherwise = rowAsTexts (const "total") tr
-- | Render a multi-column balance report as HTML. -- | Render a multi-column balance report as HTML.
multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html () multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
multiBalanceReportAsHtml ropts mbr = multiBalanceReportAsHtml ropts mbr =
let let
(headingsrow,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr (headingsrow,bodyrows,mtotalsrows) = multiBalanceReportHtmlRows ropts mbr
in in
table_ $ mconcat $ table_ $ mconcat $
[headingsrow] [headingsrow]
++ bodyrows ++ bodyrows
++ maybeToList mtotalsrow ++ mtotalsrows
-- | Render the HTML table rows for a MultiBalanceReport. -- | Render the HTML table rows for a MultiBalanceReport.
-- Returns the heading row, 0 or more body rows, and the totals row if enabled. -- Returns the heading row, 0 or more body rows, and the totals row if enabled.
multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ())) multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], [Html ()])
multiBalanceReportHtmlRows ropts mbr = multiBalanceReportHtmlRows ropts mbr =
let let
headingsrow:rest | transpose_ ropts = error' "Sorry, --transpose with HTML output is not yet supported" -- PARTIAL: -- TODO: should the commodity_column be displayed as a subaccount in this case as well?
| otherwise = multiBalanceReportAsCsv ropts mbr (headingsrow:bodyrows, mtotalsrows)
(bodyrows, mtotalsrow) | no_total_ ropts = (rest, Nothing) | transpose_ ropts = error' "Sorry, --transpose with HTML output is not yet supported" -- PARTIAL:
| otherwise = (init rest, Just $ last rest) | otherwise = multiBalanceReportAsCsv' ropts mbr
in in
(multiBalanceReportHtmlHeadRow ropts headingsrow (multiBalanceReportHtmlHeadRow ropts headingsrow
,map (multiBalanceReportHtmlBodyRow ropts) bodyrows ,map (multiBalanceReportHtmlBodyRow ropts) bodyrows
,multiBalanceReportHtmlFootRow ropts <$> mtotalsrow -- TODO pad totals row with zeros when there are ,multiBalanceReportHtmlFootRow ropts <$> mtotalsrows -- TODO pad totals row with zeros when there are
) )
-- | Render one MultiBalanceReport heading row as a HTML table row. -- | Render one MultiBalanceReport heading row as a HTML table row.
@ -627,7 +675,8 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balanceaccum_}
(map rowvals items) (map rowvals items)
where where
totalscolumn = row_total_ && balanceaccum_ `notElem` [Cumulative, Historical] totalscolumn = row_total_ && balanceaccum_ `notElem` [Cumulative, Historical]
colheadings = map (reportPeriodName balanceaccum_ spans) spans colheadings = ["Commodity" | commodity_column_ opts]
++ map (reportPeriodName balanceaccum_ spans) spans
++ [" Total" | totalscolumn] ++ [" Total" | totalscolumn]
++ ["Average" | average_] ++ ["Average" | average_]
accts = map renderacct items accts = map renderacct items
@ -651,9 +700,28 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balanceaccum_}
-- unless --no-elide is used. -- unless --no-elide is used.
balanceReportTableAsText :: ReportOpts -> Table T.Text T.Text MixedAmount -> TB.Builder balanceReportTableAsText :: ReportOpts -> Table T.Text T.Text MixedAmount -> TB.Builder
balanceReportTableAsText ropts@ReportOpts{..} = balanceReportTableAsText ropts@ReportOpts{..} =
Tab.renderTableB def{tableBorders=False, prettyTable=pretty_tables_} Tab.renderTableByRowsB def{tableBorders=False, prettyTable=pretty_tables_} renderCh renderRow
(Tab.textCell TopLeft) (Tab.textCell TopRight) $ where
Cell TopRight . pure . showMixedAmountB (balanceOpts True ropts) renderCh
| not commodity_column_ = fmap (Tab.textCell TopRight)
| otherwise = zipWith ($) (Tab.textCell TopLeft : repeat (Tab.textCell TopRight))
renderRow :: (T.Text, [MixedAmount]) -> (Cell, [Cell])
renderRow (rh, row)
| not commodity_column_ =
(Tab.textCell TopLeft rh, fmap (Cell TopRight . pure . showMixedAmountB bopts) row)
| otherwise =
( Tab.textsCell TopLeft (replicate (length cs) rh)
, Tab.textsCell TopLeft cs
: fmap (Cell TopRight . showMixedAmountLinesB bopts{displayOrder = Just cs}) row)
where
bopts = balanceOpts True ropts
cs = commodities row
commodities :: [MixedAmount] -> [CommoditySymbol]
commodities = filter (not . T.null) . S.toList
. foldl' S.union mempty
. fmap (S.fromList . fmap acommodity . amounts)
-- | Amount display options to use for balance reports -- | Amount display options to use for balance reports
balanceOpts :: Bool -> ReportOpts -> AmountDisplayOpts balanceOpts :: Bool -> ReportOpts -> AmountDisplayOpts

View File

@ -297,11 +297,11 @@ compoundBalanceReportAsHtml ropts cbr =
subreportrows :: (T.Text, MultiBalanceReport, Bool) -> [Html ()] subreportrows :: (T.Text, MultiBalanceReport, Bool) -> [Html ()]
subreportrows (subreporttitle, mbr, _increasestotal) = subreportrows (subreporttitle, mbr, _increasestotal) =
let let
(_,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr (_,bodyrows,mtotalsrows) = multiBalanceReportHtmlRows ropts mbr
in in
[tr_ $ th_ [colspanattr, leftattr] $ toHtml subreporttitle] [tr_ $ th_ [colspanattr, leftattr] $ toHtml subreporttitle]
++ bodyrows ++ bodyrows
++ maybe [] (:[]) mtotalsrow ++ mtotalsrows
++ [blankrow] ++ [blankrow]
totalrows | no_total_ ropts || length subreports == 1 = [] totalrows | no_total_ ropts || length subreports == 1 = []