{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
module Hledger.Cli.CompoundBalanceCommand (
CompoundBalanceCommandSpec(..)
,compoundBalanceCommandMode
,compoundBalanceCommand
) where
import Data.List (foldl')
import Data.Maybe
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
import Data.Time.Calendar
import System.Console.CmdArgs.Explicit as C
import Hledger.Read.CsvReader (CSV, printCSV)
import Lucid as L hiding (value_)
import Text.Tabular as T
import Hledger
import Hledger.Cli.Commands.Balance
import Hledger.Cli.CliOptions
import Hledger.Cli.Utils (unsupportedOutputFormatError, writeOutput)
data CompoundBalanceCommandSpec = CompoundBalanceCommandSpec {
cbcdoc :: CommandDoc,
cbctitle :: String,
cbcqueries :: [CBCSubreportSpec],
cbctype :: BalanceType
}
compoundBalanceCommandMode :: CompoundBalanceCommandSpec -> Mode RawOpts
compoundBalanceCommandMode CompoundBalanceCommandSpec{..} =
hledgerCommandMode
cbcdoc
([flagNone ["change"] (setboolopt "change")
("show balance change in each period" ++ defType PeriodChange)
,flagNone ["cumulative"] (setboolopt "cumulative")
("show balance change accumulated across periods (in multicolumn reports)"
++ defType CumulativeChange
)
,flagNone ["historical","H"] (setboolopt "historical")
("show historical ending balance in each period (includes postings before report start date)"
++ defType HistoricalBalance
)
]
++ flattreeflags True ++
[flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "flat mode: omit N leading account name parts"
,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"
,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 when displaying tables"
,flagNone ["sort-amount","S"] (setboolopt "sort-amount") "sort by amount instead of account code/name"
,flagNone ["percent", "%"] (setboolopt "percent") "express values in percentage of each column's total"
,outputFormatFlag ["txt","html","csv","json"]
,outputFileFlag
])
[generalflagsgroup1]
hiddenflags
([], Just $ argsFlag "[QUERY]")
where
defType :: BalanceType -> String
defType bt | bt == cbctype = " (default)"
| otherwise = ""
compoundBalanceCommand :: CompoundBalanceCommandSpec -> (CliOpts -> Journal -> IO ())
compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=ropts@ReportOpts{..}, rawopts_=rawopts} j = do
today <- getCurrentDay
let
mBalanceTypeOverride =
choiceopt parse rawopts where
parse = \case
"historical" -> Just HistoricalBalance
"cumulative" -> Just CumulativeChange
"change" -> Just PeriodChange
_ -> Nothing
balancetype = fromMaybe cbctype mBalanceTypeOverride
ropts' = ropts{balancetype_=balancetype}
title =
cbctitle
++ " "
++ titledatestr
++ maybe "" (' ':) mtitleclarification
++ valuationdesc
where
titledatestr = case balancetype of
HistoricalBalance -> showEndDates enddates
_ -> showDateSpan requestedspan
where
enddates = map (addDays (-1)) . mapMaybe spanEnd $ cbrDates cbr
requestedspan = queryDateSpan date2_ (queryFromOpts today ropts')
`spanDefaultsFrom` journalDateSpan date2_ j
mtitleclarification = flip fmap mBalanceTypeOverride $ \t ->
case t of
PeriodChange -> "(Balance Changes)"
CumulativeChange -> "(Cumulative Ending Balances)"
HistoricalBalance -> "(Historical Ending Balances)"
valuationdesc = 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 today _mc) -> ", valued at "++showDate today
Nothing -> ""
where multiperiod = interval_ /= NoInterval
cbr' = compoundBalanceReport today ropts' j cbcqueries
cbr = cbr'{cbrTitle=title}
writeOutput opts $ case outputFormatFromOpts opts of
"txt" -> compoundBalanceReportAsText ropts' cbr
"csv" -> printCSV (compoundBalanceReportAsCsv ropts cbr) ++ "\n"
"html" -> (++"\n") $ TL.unpack $ L.renderText $ compoundBalanceReportAsHtml ropts cbr
"json" -> (++"\n") $ TL.unpack $ toJsonText cbr
x -> error' $ unsupportedOutputFormatError x
showEndDates :: [Day] -> String
showEndDates es = case es of
(e:_:_) -> showdate e ++ ".." ++ showdate (last es)
[e] -> showdate e
[] -> ""
where
showdate = show
compoundBalanceReportAsText :: ReportOpts -> CompoundBalanceReport -> String
compoundBalanceReportAsText ropts
(CompoundPeriodicReport title _colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
title ++ "\n\n" ++
balanceReportTableAsText ropts bigtable'
where
bigtable =
case map (subreportAsTable ropts) subreports of
[] -> T.empty
r:rs -> foldl' concatTables r rs
bigtable'
| no_total_ ropts || length subreports == 1 =
bigtable
| otherwise =
bigtable
+====+
row "Net:" (
coltotals
++ (if row_total_ ropts then [grandtotal] else [])
++ (if average_ ropts then [grandavg] else [])
)
subreportAsTable ropts (title, r, _) = t
where
Table lefthdrs tophdrs cells = balanceReportAsTable ropts r
t = Table (T.Group SingleLine [Header title, lefthdrs]) tophdrs ([]:cells)
concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =
Table (T.Group DoubleLine [hLeft, hLeft']) hTop (dat ++ dat')
compoundBalanceReportAsCsv :: ReportOpts -> CompoundBalanceReport -> CSV
compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
addtotals $
padRow title :
("Account" :
map showDateSpanMonthAbbrev colspans
++ (if row_total_ ropts then ["Total"] else [])
++ (if average_ ropts then ["Average"] else [])
) :
concatMap (subreportAsCsv ropts) subreports
where
subreportAsCsv ropts (subreporttitle, multibalreport, _) =
padRow subreporttitle :
tail (multiBalanceReportAsCsv ropts multibalreport)
padRow s = take numcols $ s : repeat ""
where
numcols
| null subreports = 1
| otherwise =
(1 +) $
(if row_total_ ropts then (1+) else id) $
(if average_ ropts then (1+) else id) $
maximum $
map (length . prDates . second3) subreports
addtotals
| no_total_ ropts || length subreports == 1 = id
| otherwise = (++
["Net:" :
map (showMixedAmountOneLineWithoutPrice False) (
coltotals
++ (if row_total_ ropts then [grandtotal] else [])
++ (if average_ ropts then [grandavg] else [])
)
])
compoundBalanceReportAsHtml :: ReportOpts -> CompoundBalanceReport -> Html ()
compoundBalanceReportAsHtml ropts cbr =
let
CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg) = cbr
colspanattr = colspan_ $ TS.pack $ show $
1 + length colspans + (if row_total_ ropts then 1 else 0) + (if average_ ropts then 1 else 0)
leftattr = style_ "text-align:left"
blankrow = tr_ $ td_ [colspanattr] $ toHtmlRaw (" "::String)
titlerows =
[tr_ $ th_ [colspanattr, leftattr] $ h2_ $ toHtml title]
++ [thRow $
"" :
map showDateSpanMonthAbbrev colspans
++ (if row_total_ ropts then ["Total"] else [])
++ (if average_ ropts then ["Average"] else [])
]
thRow :: [String] -> Html ()
thRow = tr_ . mconcat . map (th_ . toHtml)
subreportrows :: (String, MultiBalanceReport, Bool) -> [Html ()]
subreportrows (subreporttitle, mbr, _increasestotal) =
let
(_,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr
in
[tr_ $ th_ [colspanattr, leftattr] $ toHtml subreporttitle]
++ bodyrows
++ maybe [] (:[]) mtotalsrow
++ [blankrow]
totalrows | no_total_ ropts || length subreports == 1 = []
| otherwise =
let defstyle = style_ "text-align:right"
in
[tr_ $ mconcat $
th_ [class_ "", style_ "text-align:left"] "Net:"
: [th_ [class_ "amount coltotal", defstyle] (toHtml $ showMixedAmountOneLineWithoutPrice False a) | a <- coltotals]
++ (if row_total_ ropts then [th_ [class_ "amount coltotal", defstyle] $ toHtml $ showMixedAmountOneLineWithoutPrice False grandtotal] else [])
++ (if average_ ropts then [th_ [class_ "amount colaverage", defstyle] $ toHtml $ showMixedAmountOneLineWithoutPrice False grandavg] else [])
]
in do
style_ (TS.unlines [""
,"td { padding:0 0.5em; }"
,"td:nth-child(1) { white-space:nowrap; }"
,"tr:nth-child(even) td { background-color:#eee; }"
])
link_ [rel_ "stylesheet", href_ "hledger.css"]
table_ $ mconcat $
titlerows
++ [blankrow]
++ concatMap subreportrows subreports
++ totalrows