{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Cli.Commands.Balance (
balancemode
,balance
,balanceReportAsText
,balanceReportItemAsText
,multiBalanceReportAsText
,multiBalanceReportAsCsv
,multiBalanceReportAsHtml
,multiBalanceReportHtmlRows
,renderBalanceReportTable
,balanceReportAsTable
,tests_Hledger_Cli_Commands_Balance
) where
import Data.Decimal
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import System.Console.CmdArgs.Explicit as C
import Data.Decimal (roundTo)
import Lucid as L
import Text.CSV
import Test.HUnit
import Text.Printf (printf)
import Text.Tabular as T
import Text.Tabular.AsciiWide
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Utils
balancemode = (defCommandMode $ ["balance"] ++ aliases) {
modeHelp = "show accounts and balances" `withAliases` aliases
,modeGroupFlags = C.Group {
groupUnnamed = [
flagNone ["change"] (\opts -> setboolopt "change" opts)
"show balance change in each period (default)"
,flagNone ["cumulative"] (\opts -> setboolopt "cumulative" opts)
"show balance change accumulated across periods (in multicolumn reports)"
,flagNone ["historical","H"] (\opts -> setboolopt "historical" opts)
"show historical ending balance in each period (includes postings before report start date)\n "
,flagNone ["tree"] (\opts -> setboolopt "tree" opts) "show accounts as a tree; amounts include subaccounts (default in simple reports)"
,flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show accounts as a list; amounts exclude subaccounts except when account is depth-clipped (default in multicolumn reports)\n "
,flagNone ["average","A"] (\opts -> setboolopt "average" opts) "show a row average column (in multicolumn reports)"
,flagNone ["row-total","T"] (\opts -> setboolopt "row-total" opts) "show a row total column (in multicolumn reports)"
,flagNone ["no-total","N"] (\opts -> setboolopt "no-total" opts) "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"] (\opts -> setboolopt "no-elide" opts) "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"] (\opts -> setboolopt "pretty-tables" opts) "use unicode to display prettier tables"
,flagNone ["sort-amount","S"] (\opts -> setboolopt "sort-amount" opts) "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 ["show-unbudgeted"] (setboolopt "show-unbudgeted") "with --budget, show unbudgeted accounts also"
,flagNone ["invert"] (setboolopt "invert") "display all amounts with reversed sign"
]
++ outputflags
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["b","bal"]
balance :: CliOpts -> Journal -> IO ()
balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
d <- getCurrentDay
case lineFormatFromOpts ropts of
Left err -> error' $ unlines [err]
Right _ -> do
let format = outputFormatFromOpts opts
interval = interval_ ropts
case interval of
NoInterval -> do
let report
| balancetype_ ropts `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 format of
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r
"html" -> \_ _ -> error' "Sorry, HTML output is not yet implemented for this kind of report."
_ -> balanceReportAsText
writeOutput opts $ render ropts report
_ | boolopt "budget" rawopts -> do
reportspan <- reportSpan j ropts
let budget = budgetJournal opts reportspan j
j' = budgetRollUp opts budget j
report = dbg1 "report" $ multiBalanceReport ropts (queryFromOpts d ropts) j'
budgetReport = dbg1 "budgetreport" $ multiBalanceReport ropts (queryFromOpts d ropts) budget
render = case format of
"csv" -> const $ error' "Sorry, CSV output is not yet implemented for this kind of report."
"html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report."
_ -> multiBalanceReportWithBudgetAsText ropts budgetReport
writeOutput opts $ render report
| otherwise -> do
let report = multiBalanceReport ropts (queryFromOpts d ropts) j
render = case format of
"csv" -> (++ "\n") . printCSV . multiBalanceReportAsCsv ropts
"html" -> (++ "\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts
_ -> multiBalanceReportAsText ropts
writeOutput opts $ render report
budgetRollUp :: CliOpts -> Journal -> Journal -> Journal
budgetRollUp CliOpts{rawopts_=rawopts} budget j = j { jtxns = remapTxn <$> jtxns j }
where
budgetAccounts = nub $ concatMap (map paccount . ptpostings) $ jperiodictxns budget
remapAccount origAcctName = remapAccount' origAcctName
where
remapAccount' acctName
| acctName `elem` budgetAccounts = acctName
| otherwise =
case parentAccountName acctName of
"" | boolopt "show-unbudgeted" rawopts -> origAcctName
| otherwise -> T.append (T.pack "<unbudgeted>:") acctName
parent -> remapAccount' parent
remapPosting p = p { paccount = remapAccount $ paccount p, porigin = Just . fromMaybe p $ porigin p }
remapTxn = mapPostings (map remapPosting)
mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t }
budgetJournal :: CliOpts -> DateSpan -> Journal -> Journal
budgetJournal opts reportspan j = journalBalanceTransactions' opts j { jtxns = budgetts }
where
budgetinterval = dbg2 "budgetinterval" $ intervalFromRawOpts $ rawopts_ opts
budgetspan = dbg2 "budgetspan" $ reportspan
budgetts =
dbg1 "budgetts" $
[makeBudgetTxn t
| pt <- jperiodictxns j
, periodTransactionInterval pt == Just budgetinterval
, t <- runPeriodicTransaction pt budgetspan
]
makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }
journalBalanceTransactions' opts j =
let assrt = not . ignore_assertions_ $ inputopts_ opts
in
either error' id $ journalBalanceTransactions assrt j
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 _ -> []
tests_balanceReportAsText = [
"balanceReportAsText" ~: do
j <- readJournal'
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
let opts = defreportopts
balanceReportAsText opts (balanceReport opts (queryFromOpts (parsedate "2008/11/26") opts) j) `is`
unlines
[" -100 актив:наличные"
," 100 расходы:покупки"
,"--------------------"
," 0"
]
]
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 (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
("Account" : map showDateSpan colspans
++ (if row_total_ opts then ["Total"] else [])
++ (if average_ opts then ["Average"] else [])
) :
[T.unpack (maybeAccountNameDrop opts a) :
map showMixedAmountOneLineWithoutPrice
(amts
++ (if row_total_ opts then [rowtot] else [])
++ (if average_ opts then [rowavg] else []))
| (a, _, _, amts, rowtot, rowavg) <- items]
++
if no_total_ opts
then []
else [["Total:"]
++ map showMixedAmountOneLineWithoutPrice (
coltotals
++ (if row_total_ opts then [tot] else [])
++ (if average_ opts then [avg] else [])
)]
multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
multiBalanceReportAsHtml ropts mbr =
let
(headingsrow,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr
in
table_ $ mconcat $
[headingsrow]
++ bodyrows
++ maybe [] (:[]) mtotalsrow
multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ()))
multiBalanceReportHtmlRows ropts mbr =
let
headingsrow:rest = 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 opts r =
printf "%s in %s:\n\n" desc (showDateSpan $ multiBalanceReportSpan r)
++ renderBalanceReportTable opts tabl
where
tabl = balanceReportAsTable opts r
desc = case balancetype_ opts of
PeriodChange -> "Balance changes"
CumulativeChange -> "Ending balances (cumulative)"
HistoricalBalance -> "Ending balances (historical)"
type ActualAmount = MixedAmount
type BudgetAmount = MixedAmount
type ActualAmountsReport = MultiBalanceReport
type BudgetAmountsReport = MultiBalanceReport
type ActualAmountsTable = Table String String MixedAmount
type BudgetAmountsTable = Table String String MixedAmount
type ActualAndBudgetAmountsTable = Table String String (Maybe MixedAmount, Maybe MixedAmount)
type Percentage = Decimal
multiBalanceReportWithBudgetAsText :: ReportOpts -> BudgetAmountsReport -> ActualAmountsReport -> String
multiBalanceReportWithBudgetAsText opts budgetr actualr =
printf "%s in %s:\n\n" desc (showDateSpan $ multiBalanceReportSpan actualr)
++ renderBalanceReportTable' opts showcell actualandbudgetamts
where
desc :: String
desc = case balancetype_ opts of
PeriodChange -> "Balance changes"
CumulativeChange -> "Ending balances (cumulative)"
HistoricalBalance -> "Ending balances (historical)"
actualandbudgetamts :: ActualAndBudgetAmountsTable
actualandbudgetamts = combineTables (balanceReportAsTable opts actualr) (balanceReportAsTable opts budgetr)
showcell :: (Maybe ActualAmount, Maybe BudgetAmount) -> String
showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr
where
actualwidth = 7
percentwidth = 4
budgetwidth = 5
actualstr = printf ("%"++show actualwidth++"s") (maybe "" showamt mactual)
budgetstr = case (mactual, mbudget) of
(_, Nothing) -> replicate (percentwidth + 7 + budgetwidth) ' '
(mactual, Just budget) ->
case percentage mactual budget of
Just pct ->
printf ("[%"++show percentwidth++"s%% of %"++show budgetwidth++"s]")
(show $ roundTo 0 pct) (showamt budget)
Nothing ->
printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]")
(showamt budget)
percentage :: Maybe ActualAmount -> BudgetAmount -> Maybe Percentage
percentage Nothing _ = Nothing
percentage (Just actual) budget =
case (toCost actual, toCost budget) of
(Mixed [a1], Mixed [a2])
| isReallyZeroAmount a1 -> Just 0
| acommodity a1 == acommodity a2 && aquantity a2 /= 0 ->
Just $ 100 * aquantity a1 / aquantity a2
_ -> Nothing
where
toCost = normaliseMixedAmount . costOfMixedAmount
showamt :: MixedAmount -> String
showamt | color_ opts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
combineTables :: ActualAmountsTable -> BudgetAmountsTable -> ActualAndBudgetAmountsTable
combineTables (Table aaccthdrs adatehdrs arows) (Table baccthdrs bdatehdrs brows) =
addtotalrow $ Table caccthdrs cdatehdrs crows
where
[aaccts, adates, baccts, bdates] = map headerContents [aaccthdrs, adatehdrs, baccthdrs, bdatehdrs]
caccts = dbg2 "caccts" $ init $ (dbg2 "aaccts" $ filter (not . null) aaccts) `union` (dbg2 "baccts" baccts)
caccthdrs = T.Group NoLine $ map Header $ caccts
cdates = dbg2 "cdates" $ sort $ (dbg2 "adates" adates) `union` (dbg2 "bdates" bdates)
cdatehdrs = T.Group NoLine $ map Header cdates
crows = [ combineRow (actualRow a) (budgetRow a) | a <- caccts ]
addtotalrow | no_total_ opts = id
| otherwise = (+----+ (row "" $ combineRow (actualRow "") (budgetRow "")))
combineRow arow brow =
dbg1 "row" $ [(actualAmt d, budgetAmt d) | d <- cdates]
where
actualAmt date = Map.lookup date $ Map.fromList $ zip adates arow
budgetAmt date = Map.lookup date $ Map.fromList $ zip bdates brow
actualRow acct = fromMaybe [] $ Map.lookup acct $ Map.fromList $ zip aaccts arows
budgetRow acct = fromMaybe [] $ Map.lookup acct $ Map.fromList $ zip baccts brows
renderBalanceReportTable :: ReportOpts -> Table String String MixedAmount -> String
renderBalanceReportTable ropts =
renderBalanceReportTable' ropts showamt
where
showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
renderBalanceReportTable' :: ReportOpts -> (a -> String) -> Table String String a -> String
renderBalanceReportTable' (ReportOpts { pretty_tables_ = pretty}) showamt =
unlines
. trimborder
. lines
. render pretty id id showamt
. align
where
trimborder = drop 1 . init . map (drop 1 . init)
align (Table l t d) = Table l' t d
where
acctswidth = maximum' $ map strWidth (headerContents l)
l' = padRightWide acctswidth <$> l
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
balanceReportAsTable opts (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
addtotalrow $ Table
(T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings)
(map rowvals items)
where
mkDate = case balancetype_ opts of
PeriodChange -> showDateSpanMonthAbbrev
_ -> maybe "" (showDate . prevday) . spanEnd
colheadings = map mkDate colspans
++ (if row_total_ opts then [" Total"] else [])
++ (if average_ opts then ["Average"] else [])
accts = map renderacct items
renderacct (a,a',i,_,_,_)
| tree_ opts = replicate ((i-1)*2) ' ' ++ T.unpack a'
| otherwise = T.unpack $ maybeAccountNameDrop opts a
rowvals (_,_,_,as,rowtot,rowavg) = as
++ (if row_total_ opts then [rowtot] else [])
++ (if average_ opts then [rowavg] else [])
addtotalrow | no_total_ opts = id
| otherwise = (+----+ (row "" $
coltotals
++ (if row_total_ opts && not (null coltotals) then [tot] else [])
++ (if average_ opts && not (null coltotals) then [avg] else [])
))
multiBalanceReportSpan :: MultiBalanceReport -> DateSpan
multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing
multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)
tests_Hledger_Cli_Commands_Balance = TestList
tests_balanceReportAsText