{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hledger.Cli.Commands.Balance (
balancemode
,balance
,balanceReportAsText
,balanceReportItemAsText
,multiBalanceReportAsText
,multiBalanceReportAsCsv
,multiBalanceReportAsHtml
,multiBalanceReportHtmlRows
,balanceReportAsTable
,balanceReportTableAsText
,tests_Balance
) where
import Data.Aeson (toJSON)
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import System.Console.CmdArgs.Explicit as C
import Lucid as L
import Text.Printf (printf)
import Text.Tabular as T
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Utils
import Hledger.Read.CsvReader (CSV, printCSV)
balancemode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Balance.txt")
([flagNone ["change"] (setboolopt "change")
"show balance change in each period (default)"
,flagNone ["cumulative"] (setboolopt "cumulative")
"show balance change accumulated across periods (in multicolumn reports)"
,flagNone ["historical","H"] (setboolopt "historical")
"show historical ending balance in each period (includes postings before report start date)\n "
,flagNone ["tree"] (setboolopt "tree") "show accounts as a tree; amounts include subaccounts (default in simple reports)"
,flagNone ["flat"] (setboolopt "flat") "show accounts as a list; amounts exclude subaccounts except when account is depth-clipped (default in multicolumn reports)\n "
,flagNone ["average","A"] (setboolopt "average") "show a row average column (in multicolumn reports)"
,flagNone ["row-total","T"] (setboolopt "row-total") "show a row total column (in multicolumn reports)"
,flagNone ["no-total","N"] (setboolopt "no-total") "omit the final total row"
,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "omit N leading account name parts (in flat mode)"
,flagNone ["no-elide"] (setboolopt "no-elide") "don't squash boring parent accounts (in tree mode)"
,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format (in simple reports)"
,flagNone ["pretty-tables"] (setboolopt "pretty-tables") "use unicode to display prettier tables"
,flagNone ["sort-amount","S"] (setboolopt "sort-amount") "sort by amount instead of account code/name (in flat mode). With multiple columns, sorts by the row total, or by row average if that is displayed."
,flagNone ["budget"] (setboolopt "budget") "show performance compared to budget goals defined by periodic transactions"
,flagNone ["invert"] (setboolopt "invert") "display all amounts with reversed sign"
,flagNone ["transpose"] (setboolopt "transpose") "transpose rows and columns"
,flagNone ["percent", "%"] (setboolopt "percent") "express values in percentage of each column's total"
]
++ outputflags
)
[generalflagsgroup1]
hiddenflags
([], Just $ argsFlag "[QUERY]")
balance :: CliOpts -> Journal -> IO ()
balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do
d <- getCurrentDay
case lineFormatFromOpts ropts of
Left err -> error' $ unlines [err]
Right _ -> do
let budget = boolopt "budget" rawopts
multiperiod = interval_ /= NoInterval
fmt = outputFormatFromOpts opts
if budget then do
reportspan <- reportSpan j ropts
let budgetreport = dbg1 "budgetreport" $ budgetReport ropts assrt reportspan d j
where
assrt = not $ ignore_assertions_ $ inputopts_ opts
render = case fmt of
"txt" -> budgetReportAsText ropts
"json" -> (++"\n") . pshow . toJSON
_ -> const $ error' $ unsupportedOutputFormatError fmt
writeOutput opts $ render budgetreport
else
if multiperiod then do
let report = multiBalanceReport ropts (queryFromOpts d ropts) j
render = case fmt of
"txt" -> multiBalanceReportAsText ropts
"csv" -> (++"\n") . printCSV . multiBalanceReportAsCsv ropts
"html" -> (++"\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts
"json" -> (++"\n") . pshow . toJSON
_ -> const $ error' $ unsupportedOutputFormatError fmt
writeOutput opts $ render report
else do
let report
| balancetype_ `elem` [HistoricalBalance, CumulativeChange]
= let ropts' | flat_ ropts = ropts
| otherwise = ropts{accountlistmode_=ALTree}
in balanceReportFromMultiBalanceReport ropts' (queryFromOpts d ropts) j
| otherwise = balanceReport ropts (queryFromOpts d ropts) j
render = case fmt of
"txt" -> balanceReportAsText
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r
"json" -> const $ (++"\n") . pshow . toJSON
_ -> const $ error' $ unsupportedOutputFormatError fmt
writeOutput opts $ render ropts report
balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV
balanceReportAsCsv opts (items, total) =
["account","balance"] :
[[T.unpack (maybeAccountNameDrop opts a), showMixedAmountOneLineWithoutPrice b] | (a, _, _, b) <- items]
++
if no_total_ opts
then []
else [["total", showMixedAmountOneLineWithoutPrice total]]
balanceReportAsText :: ReportOpts -> BalanceReport -> String
balanceReportAsText opts ((items, total)) = unlines $ concat lines ++ t
where
fmt = lineFormatFromOpts opts
lines = case fmt of
Right fmt -> map (balanceReportItemAsText opts fmt) items
Left err -> [[err]]
t = if no_total_ opts
then []
else
case fmt of
Right fmt ->
let
acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items]
totallines = map rstrip $ renderBalanceReportItem opts fmt (T.replicate (acctcolwidth+1) " ", 0, total)
overlinewidth | isJust (format_ opts) = maximum' $ map length $ concat lines
| otherwise = defaultTotalFieldWidth
overline = replicate overlinewidth '-'
in overline : totallines
Left _ -> []
balanceReportItemAsText :: ReportOpts -> StringFormat -> BalanceReportItem -> [String]
balanceReportItemAsText opts fmt (_, accountName, depth, amt) =
renderBalanceReportItem opts fmt (
maybeAccountNameDrop opts accountName,
depth,
normaliseMixedAmountSquashPricesForDisplay amt
)
renderBalanceReportItem :: ReportOpts -> StringFormat -> (AccountName, Int, MixedAmount) -> [String]
renderBalanceReportItem opts fmt (acctname, depth, total) =
lines $
case fmt of
OneLine comps -> concatOneLine $ render1 comps
TopAligned comps -> concatBottomPadded $ render comps
BottomAligned comps -> concatTopPadded $ render comps
where
render1 = map (renderComponent1 opts (acctname, depth, total))
render = map (renderComponent opts (acctname, depth, total))
defaultTotalFieldWidth = 20
renderComponent :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
renderComponent _ _ (FormatLiteral s) = s
renderComponent opts (acctname, depth, total) (FormatField ljust min max field) = case field of
DepthSpacerField -> formatString ljust Nothing max $ replicate d ' '
where d = case min of
Just m -> depth * m
Nothing -> depth
AccountField -> formatString ljust min max (T.unpack acctname)
TotalField -> fitStringMulti min max True False $ showamt total
where
showamt | color_ opts = cshowMixedAmountWithoutPrice
| otherwise = showMixedAmountWithoutPrice
_ -> ""
renderComponent1 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
renderComponent1 _ _ (FormatLiteral s) = s
renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) = case field of
AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented (T.unpack acctname)))
where
indented = ((replicate (depth*2) ' ')++)
TotalField -> fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showamt total))
where
showamt | color_ opts = cshowMixedAmountWithoutPrice
| otherwise = showMixedAmountWithoutPrice
_ -> ""
multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV
multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_}
(PeriodicReport colspans items (PeriodicReportRow _ _ coltotals tot avg)) =
maybetranspose $
("Account" : map showDateSpan colspans
++ ["Total" | row_total_]
++ ["Average" | average_]
) :
[T.unpack (maybeAccountNameDrop opts a) :
map showMixedAmountOneLineWithoutPrice
(amts
++ [rowtot | row_total_]
++ [rowavg | average_])
| PeriodicReportRow a _ amts rowtot rowavg <- items]
++
if no_total_ opts
then []
else ["Total:" :
map showMixedAmountOneLineWithoutPrice (
coltotals
++ [tot | row_total_]
++ [avg | average_]
)]
where
maybetranspose | transpose_ opts = transpose
| otherwise = id
multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
multiBalanceReportAsHtml ropts mbr =
let
(headingsrow,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr
in
table_ $ mconcat $
[headingsrow]
++ bodyrows
++ maybeToList mtotalsrow
multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ()))
multiBalanceReportHtmlRows ropts mbr =
let
headingsrow:rest | transpose_ ropts = error' "Sorry, --transpose is not supported with HTML output yet"
| otherwise = multiBalanceReportAsCsv ropts mbr
(bodyrows, mtotalsrow) | no_total_ ropts = (rest, Nothing)
| otherwise = (init rest, Just $ last rest)
in
(multiBalanceReportHtmlHeadRow ropts headingsrow
,map (multiBalanceReportHtmlBodyRow ropts) bodyrows
,multiBalanceReportHtmlFootRow ropts <$> mtotalsrow
)
multiBalanceReportHtmlHeadRow :: ReportOpts -> [String] -> Html ()
multiBalanceReportHtmlHeadRow _ [] = mempty
multiBalanceReportHtmlHeadRow ropts (acct:rest) =
let
defstyle = style_ ""
(amts,tot,avg)
| row_total_ ropts && average_ ropts = (init $ init rest, [last $ init rest], [last rest])
| row_total_ ropts = (init rest, [last rest], [])
| average_ ropts = (init rest, [], [last rest])
| otherwise = (rest, [], [])
in
tr_ $ mconcat $
td_ [class_ "account"] (toHtml acct)
: [td_ [class_ "", defstyle] (toHtml a) | a <- amts]
++ [td_ [class_ "rowtotal", defstyle] (toHtml a) | a <- tot]
++ [td_ [class_ "rowaverage", defstyle] (toHtml a) | a <- avg]
multiBalanceReportHtmlBodyRow :: ReportOpts -> [String] -> Html ()
multiBalanceReportHtmlBodyRow _ [] = mempty
multiBalanceReportHtmlBodyRow ropts (label:rest) =
let
defstyle = style_ "text-align:right"
(amts,tot,avg)
| row_total_ ropts && average_ ropts = (init $ init rest, [last $ init rest], [last rest])
| row_total_ ropts = (init rest, [last rest], [])
| average_ ropts = (init rest, [], [last rest])
| otherwise = (rest, [], [])
in
tr_ $ mconcat $
td_ [class_ "account", style_ "text-align:left"] (toHtml label)
: [td_ [class_ "amount", defstyle] (toHtml a) | a <- amts]
++ [td_ [class_ "amount rowtotal", defstyle] (toHtml a) | a <- tot]
++ [td_ [class_ "amount rowaverage", defstyle] (toHtml a) | a <- avg]
multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html ()
multiBalanceReportHtmlFootRow _ropts [] = mempty
multiBalanceReportHtmlFootRow ropts (acct:rest) =
let
defstyle = style_ "text-align:right"
(amts,tot,avg)
| row_total_ ropts && average_ ropts = (init $ init rest, [last $ init rest], [last rest])
| row_total_ ropts = (init rest, [last rest], [])
| average_ ropts = (init rest, [], [last rest])
| otherwise = (rest, [], [])
in
tr_ $ mconcat $
th_ [style_ "text-align:left"] (toHtml acct)
: [th_ [class_ "amount coltotal", defstyle] (toHtml a) | a <- amts]
++ [th_ [class_ "amount coltotal", defstyle] (toHtml a) | a <- tot]
++ [th_ [class_ "amount colaverage", defstyle] (toHtml a) | a <- avg]
multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String
multiBalanceReportAsText ropts@ReportOpts{..} r =
title ++ "\n\n" ++ (balanceReportTableAsText ropts $ balanceReportAsTable ropts r)
where
multiperiod = interval_ /= NoInterval
title = printf "%s in %s%s:"
(case balancetype_ of
PeriodChange -> "Balance changes"
CumulativeChange -> "Ending balances (cumulative)"
HistoricalBalance -> "Ending balances (historical)")
(showDateSpan $ periodicReportSpan r)
(case value_ of
Just (AtCost _mc) -> ", valued at cost"
Just (AtThen _mc) -> error' unsupportedValueThenError
Just (AtEnd _mc) -> ", valued at period ends"
Just (AtNow _mc) -> ", current value"
Just (AtDefault _mc) | multiperiod -> ", valued at period ends"
Just (AtDefault _mc) -> ", current value"
Just (AtDate d _mc) -> ", valued at "++showDate d
Nothing -> "")
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
(PeriodicReport colspans items (PeriodicReportRow _ _ coltotals tot avg)) =
maybetranspose $
addtotalrow $
Table
(T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings)
(map rowvals items)
where
totalscolumn = row_total_ && balancetype_ `notElem` [CumulativeChange, HistoricalBalance]
mkDate = case balancetype_ of
PeriodChange -> showDateSpanMonthAbbrev
_ -> maybe "" (showDate . prevday) . spanEnd
colheadings = map mkDate colspans
++ [" Total" | totalscolumn]
++ ["Average" | average_]
accts = map renderacct items
renderacct (PeriodicReportRow a i _ _ _)
| tree_ opts = replicate ((i-1)*2) ' ' ++ T.unpack (accountLeafName a)
| otherwise = T.unpack $ maybeAccountNameDrop opts a
rowvals (PeriodicReportRow _ _ as rowtot rowavg) = as
++ [rowtot | totalscolumn]
++ [rowavg | average_]
addtotalrow | no_total_ opts = id
| otherwise = (+----+ (row "" $
coltotals
++ [tot | totalscolumn && not (null coltotals)]
++ [avg | average_ && not (null coltotals)]
))
maybetranspose | transpose_ opts = \(Table rh ch vals) -> Table ch rh (transpose vals)
| otherwise = id
balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String
balanceReportTableAsText ropts = tableAsText ropts showamt
where
showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
tests_Balance = tests "Balance" [
tests "balanceReportAsText" [
test "unicode in balance layout" $ do
j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
let opts = defreportopts
balanceReportAsText opts (balanceReport opts (queryFromOpts (parsedate "2008/11/26") opts) j)
@?=
unlines
[" -100 актив:наличные"
," 100 расходы:покупки"
,"--------------------"
," 0"
]
]
]