diff --git a/hledger-lib/Hledger/Reports.hs b/hledger-lib/Hledger/Reports.hs index 17e80d9e1..a7b33eda7 100644 --- a/hledger-lib/Hledger/Reports.hs +++ b/hledger-lib/Hledger/Reports.hs @@ -16,6 +16,7 @@ module Hledger.Reports ( module Hledger.Reports.TransactionsReports, module Hledger.Reports.BalanceReport, module Hledger.Reports.MultiBalanceReports, + module Hledger.Reports.BudgetReport, -- module Hledger.Reports.BalanceHistoryReport, -- * Tests @@ -32,6 +33,7 @@ import Hledger.Reports.PostingsReport import Hledger.Reports.TransactionsReports import Hledger.Reports.BalanceReport import Hledger.Reports.MultiBalanceReports +import Hledger.Reports.BudgetReport -- import Hledger.Reports.BalanceHistoryReport tests_Hledger_Reports :: Test @@ -42,5 +44,6 @@ tests_Hledger_Reports = TestList $ tests_Hledger_Reports_EntriesReport, tests_Hledger_Reports_PostingsReport, tests_Hledger_Reports_BalanceReport, - tests_Hledger_Reports_MultiBalanceReport + tests_Hledger_Reports_MultiBalanceReport, + tests_Hledger_Reports_BudgetReport ] diff --git a/hledger-lib/Hledger/Reports/BudgetReport.hs b/hledger-lib/Hledger/Reports/BudgetReport.hs new file mode 100644 index 000000000..d3330d733 --- /dev/null +++ b/hledger-lib/Hledger/Reports/BudgetReport.hs @@ -0,0 +1,341 @@ +{- | +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hledger.Reports.BudgetReport +where + +import Data.Decimal +import Data.List +import Data.Maybe +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid ((<>)) +#endif +import Data.Ord +import Data.Time.Calendar +--import Safe +import Test.HUnit +--import Data.List +--import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +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.CSV +--import Test.HUnit +import Text.Printf (printf) +import Text.Tabular as T +--import Text.Tabular.AsciiWide + +import Hledger.Data +--import Hledger.Query +import Hledger.Utils +--import Hledger.Read (mamountp') +import Hledger.Reports.ReportOptions +import Hledger.Reports.ReportTypes +import Hledger.Reports.MultiBalanceReports + + +--type MultiBalanceReportRow = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount) +--type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals) + +--type PeriodicReportRow a = +-- ( AccountName -- ^ A full account name. +-- , [a] -- ^ The data value for each subperiod. +-- , a -- ^ The total of this row's values. +-- , a -- ^ The average of this row's values. +-- ) + +type BudgetGoal = Change +type BudgetTotal = Total +type BudgetAverage = Average + +-- | A budget report tracks expected and actual changes per account and subperiod. +type BudgetReport = PeriodicReport (Maybe Change, Maybe BudgetGoal) + +-- | Calculate budget goals from periodic transactions with the specified report interval, +-- calculate actual inflows/outflows from the regular transactions (adjusted to match the +-- budget goals' account tree), and return both as a 'BudgetReport'. +budgetReport :: ReportOpts -> Bool -> Bool -> DateSpan -> Day -> Journal -> BudgetReport +budgetReport ropts assrt showunbudgeted reportspan d j = + let + budgetj = budgetJournal assrt ropts reportspan j + actualj = budgetRollUp showunbudgeted budgetj j + q = queryFromOpts d ropts + budgetgoalreport = dbg1 "budgetgoalreport" $ multiBalanceReport ropts q budgetj + actualreport = dbg1 "actualreport" $ multiBalanceReport ropts q actualj + in + dbg1 "budgetreport" $ + combineBudgetAndActual budgetgoalreport actualreport + +-- | Select all periodic transactions from the given journal which +-- match the requested report interval, and use them to generate +-- budget transactions (like forecast transactions) in the specified +-- report period (calculated in IO and passed in). +budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal +budgetJournal assrt ropts reportspan j = + either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts } + where + budgetinterval = dbg2 "budgetinterval" $ interval_ ropts + 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" } + +-- | Re-map account names to closest parent with periodic transaction from budget. +-- Accounts that don't have suitable parent are either remapped to ":topAccount" +-- or left as-is if --show-unbudgeted is provided. +budgetRollUp :: Bool -> Journal -> Journal -> Journal +budgetRollUp showunbudgeted 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 + "" | showunbudgeted -> origAcctName + | otherwise -> T.append (T.pack ":") acctName -- TODO: --drop should not remove this + 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 } + +-- | Combine a per-account-and-subperiod report of budget goals, and one +-- of actual change amounts, into a budget performance report. +-- The two reports should have the same report interval, but need not +-- have exactly the same account rows or date columns. +-- (Cells in the combined budget report can be missing a budget goal, +-- an actual amount, or both.) The combined report will include: +-- +-- - consecutive subperiods at the same interval as the two reports, +-- spanning the period of both reports +-- +-- - all accounts mentioned in either report, sorted by account code or +-- account name or amount as appropriate. +-- +combineBudgetAndActual :: MultiBalanceReport -> MultiBalanceReport -> BudgetReport +combineBudgetAndActual + (MultiBalanceReport (budgetperiods, budgetrows, (budgettots, budgetgrandtot, budgetgrandavg))) + (MultiBalanceReport (actualperiods, actualrows, (actualtots, actualgrandtot, actualgrandavg))) = + let + periods = nub $ sort $ filter (/= nulldatespan) $ budgetperiods ++ actualperiods + + -- first, combine any corresponding budget goals with actual changes + rows1 = + [ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal) + | (acct, treeacct, treeindent, actualamts, actualtot, actualavg) <- actualrows + , let mbudgetgoals = Map.lookup acct budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage) + , let budgetmamts = maybe (replicate (length periods) Nothing) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal] + , let mbudgettot = maybe Nothing (Just . second3) mbudgetgoals :: Maybe BudgetTotal + , let mbudgetavg = maybe Nothing (Just . third3) mbudgetgoals :: Maybe BudgetAverage + , let acctBudgetByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal + , let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change + , let amtandgoals = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)] + , let totamtandgoal = (Just actualtot, mbudgettot) + , let avgamtandgoal = (Just actualavg, mbudgetavg) + ] + where + budgetGoalsByAcct :: Map AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) = + Map.fromList [ (acct, (amts, tot, avg)) | (acct, _, _, amts, tot, avg) <- budgetrows ] + + -- next, make rows for budget goals with no actual changes + rows2 = + [ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal) + | (acct, treeacct, treeindent, budgetgoals, budgettot, budgetavg) <- budgetrows + , not $ acct `elem` acctsdone + , let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal + , let amtandgoals = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)] + , let totamtandgoal = (Nothing, Just budgettot) + , let avgamtandgoal = (Nothing, Just budgetavg) + ] + where + acctsdone = map first6 rows1 + + -- combine and re-sort rows + -- TODO: respect hierarchy in tree mode + -- TODO: respect --sort-amount + -- TODO: add --sort-budget + rows :: [PeriodicReportRow (Maybe Change, Maybe BudgetGoal)] = + sortBy (comparing first6) $ rows1 ++ rows2 +-- massive duplication from multiBalanceReport to handle tree mode sorting ? +-- dbg1 "sorteditems" $ +-- sortitems items +-- where +-- sortitems +-- | sort_amount_ opts && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAmount +-- | sort_amount_ opts = sortFlatMultiBalanceReportRowsByAmount +-- | not (sort_amount_ opts) && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAccountCodeAndName +-- | otherwise = sortFlatMultiBalanceReportRowsByAccountCodeAndName +-- where +-- -- Sort the report rows, representing a flat account list, by row total. +-- sortFlatMultiBalanceReportRowsByAmount = sortBy (maybeflip $ comparing fifth6) +-- where +-- maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip +-- +-- -- Sort the report rows, representing a tree of accounts, by row total at each level. +-- -- To do this we recreate an Account tree with the row totals as balances, +-- -- so we can do a hierarchical sort, flatten again, and then reorder the +-- -- report rows similarly. Yes this is pretty long winded. +-- sortTreeMultiBalanceReportRowsByAmount rows = sortedrows +-- where +-- anamesandrows = [(first6 r, r) | r <- rows] +-- anames = map fst anamesandrows +-- atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows] +-- nametree = treeFromPaths $ map expandAccountName anames +-- accounttree = nameTreeToAccount "root" nametree +-- accounttreewithbals = mapAccounts setibalance accounttree +-- where +-- -- this error should not happen, but it's ugly TODO +-- setibalance a = a{aibalance=fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 1") $ lookup (aname a) atotals} +-- sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals +-- sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree +-- -- dropped the root account, also ignore any parent accounts not in rows +-- sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts +-- +-- -- Sort the report rows by account code if any, with the empty account code coming last, then account name. +-- sortFlatMultiBalanceReportRowsByAccountCodeAndName = sortBy (comparing acodeandname) +-- where +-- acodeandname r = (acode', aname) +-- where +-- aname = first6 r +-- macode = fromMaybe Nothing $ lookup aname $ jaccounts j +-- acode' = fromMaybe maxBound macode +-- +-- -- Sort the report rows, representing a tree of accounts, by account code and then account name at each level. +-- -- Convert a tree of account names, look up the account codes, sort and flatten the tree, reorder the rows. +-- sortTreeMultiBalanceReportRowsByAccountCodeAndName rows = sortedrows +-- where +-- anamesandrows = [(first6 r, r) | r <- rows] +-- anames = map fst anamesandrows +-- nametree = treeFromPaths $ map expandAccountName anames +-- accounttree = nameTreeToAccount "root" nametree +-- accounttreewithcodes = mapAccounts (accountSetCodeFrom j) accounttree +-- sortedaccounttree = sortAccountTreeByAccountCodeAndName accounttreewithcodes +-- sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree +-- -- dropped the root account, also ignore any parent accounts not in rows +-- sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts +-- + + -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells + totalrow = + ( "" + , "" + , 0 + , [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] :: [(Maybe Total, Maybe BudgetTotal)] + , ( Just actualgrandtot, Just budgetgrandtot ) :: (Maybe Total, Maybe BudgetTotal) + , ( Just actualgrandavg, Just budgetgrandavg ) :: (Maybe Total, Maybe BudgetTotal) + ) + where + totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal + totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change + + in + PeriodicReport + ( periods + , rows + , totalrow + ) + +-- | Figure out the overall period of a BudgetReport. +budgetReportSpan :: BudgetReport -> DateSpan +budgetReportSpan (PeriodicReport ([], _, _)) = DateSpan Nothing Nothing +budgetReportSpan (PeriodicReport (spans, _, _)) = DateSpan (spanStart $ head spans) (spanEnd $ last spans) + +-- | Render a budget report as plain text suitable for console output. +budgetReportAsText :: ReportOpts -> BudgetReport -> String +budgetReportAsText ropts budgetr = + printf "Budget performance in %s:\n\n" (showDateSpan $ budgetReportSpan budgetr) + ++ + tableAsText ropts showcell (budgetReportAsTable ropts budgetr) + where + showcell :: (Maybe Change, Maybe BudgetGoal) -> String + showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr + where + actualwidth = 7 + percentwidth = 4 + budgetwidth = 5 + actualstr = printf ("%"++show actualwidth++"s") (maybe "0" 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) (showbudgetamt budget) + Nothing -> + printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]") + (showbudgetamt budget) + + percentage :: Maybe Change -> BudgetGoal -> Maybe Percentage + percentage Nothing _ = Nothing + percentage (Just actual) budget = + -- percentage of budget consumed is always computed in the cost basis + case (toCost actual, toCost budget) of + (Mixed [a1], Mixed [a2]) + | isReallyZeroAmount a1 -> Just 0 -- if there are no postings, we consumed 0% of budget + | acommodity a1 == acommodity a2 && aquantity a2 /= 0 -> + Just $ 100 * aquantity a1 / aquantity a2 + _ -> Nothing + where + toCost = normaliseMixedAmount . costOfMixedAmount + + showamt :: MixedAmount -> String + showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice + | otherwise = showMixedAmountOneLineWithoutPrice + + -- don't show the budget amount in color, it messes up alignment + showbudgetamt = showMixedAmountOneLineWithoutPrice + +-- | Build a 'Table' from a multi-column balance report. +budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount) +budgetReportAsTable + ropts + (PeriodicReport + ( periods + , rows + , (_, _, _, coltots, grandtot, grandavg) + )) = + addtotalrow $ + Table + (T.Group NoLine $ map Header accts) + (T.Group NoLine $ map Header colheadings) + (map rowvals rows) + where + colheadings = map showDateSpanMonthAbbrev periods + ++ (if row_total_ ropts then [" Total"] else []) + ++ (if average_ ropts then ["Average"] else []) + accts = map renderacct rows + renderacct (a,a',i,_,_,_) + | tree_ ropts = replicate ((i-1)*2) ' ' ++ T.unpack a' + | otherwise = T.unpack $ maybeAccountNameDrop ropts a + rowvals (_,_,_,as,rowtot,rowavg) = as + ++ (if row_total_ ropts then [rowtot] else []) + ++ (if average_ ropts then [rowavg] else []) + addtotalrow | no_total_ ropts = id + | otherwise = (+----+ (row "" $ + coltots + ++ (if row_total_ ropts && not (null coltots) then [grandtot] else []) + ++ (if average_ ropts && not (null coltots) then [grandavg] else []) + )) + +-- XXX here for now +-- | Drop leading components of accounts names as specified by --drop, but only in --flat mode. +maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName +maybeAccountNameDrop opts a | tree_ opts = a + | otherwise = accountNameDrop (drop_ opts) a + +tests_Hledger_Reports_BudgetReport :: Test +tests_Hledger_Reports_BudgetReport = TestList [ + ] diff --git a/hledger-lib/Hledger/Reports/MultiBalanceReports.hs b/hledger-lib/Hledger/Reports/MultiBalanceReports.hs index caabe89f4..721a8d732 100644 --- a/hledger-lib/Hledger/Reports/MultiBalanceReports.hs +++ b/hledger-lib/Hledger/Reports/MultiBalanceReports.hs @@ -12,6 +12,8 @@ module Hledger.Reports.MultiBalanceReports ( balanceReportFromMultiBalanceReport, mbrNegate, mbrNormaliseSign, + multiBalanceReportSpan, + tableAsText, -- -- * Tests tests_Hledger_Reports_MultiBalanceReport @@ -24,6 +26,8 @@ import Data.Ord import Data.Time.Calendar import Safe import Test.HUnit +import Text.Tabular as T +import Text.Tabular.AsciiWide import Hledger.Data import Hledger.Query @@ -259,6 +263,11 @@ mbrNegate (MultiBalanceReport (colspans, rows, totalsrow)) = mbrRowNegate (acct,shortacct,indent,amts,tot,avg) = (acct,shortacct,indent,map negate amts,-tot,-avg) mbrTotalsRowNegate (amts,tot,avg) = (map negate amts,-tot,-avg) +-- | Figure out the overall date span of a multicolumn balance report. +multiBalanceReportSpan :: MultiBalanceReport -> DateSpan +multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing +multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans) + -- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport, -- in order to support --historical. Does not support tree-mode boring parent eliding. -- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts @@ -322,6 +331,22 @@ tests_multiBalanceReport = Mixed [usd0]) ] +-- common rendering helper, XXX here for now + +tableAsText :: ReportOpts -> (a -> String) -> Table String String a -> String +tableAsText (ReportOpts{pretty_tables_ = pretty}) showcell = + unlines + . trimborder + . lines + . render pretty id id showcell + . 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 + tests_Hledger_Reports_MultiBalanceReport :: Test tests_Hledger_Reports_MultiBalanceReport = TestList tests_multiBalanceReport diff --git a/hledger-lib/Hledger/Reports/ReportTypes.hs b/hledger-lib/Hledger/Reports/ReportTypes.hs index 787cf5f80..625cccdea 100644 --- a/hledger-lib/Hledger/Reports/ReportTypes.hs +++ b/hledger-lib/Hledger/Reports/ReportTypes.hs @@ -22,19 +22,19 @@ type Average = MixedAmount -- ^ The average of 'Change's or 'Balance's in a rep -- budget performance, etc. Successor to MultiBalanceReport. data PeriodicReport a = PeriodicReport - ( [DateSpan] -- ^ The subperiods formed by spliting the overall report period by the report interval. - -- For ending-balance reports, only the end date is significant. - -- Usually displayed as report columns. - , [PeriodicReportRow a] -- ^ One row per account in the report. - , PeriodicReportRow a -- ^ The grand totals row. The account name in this row is always empty. + ( [DateSpan] -- The subperiods formed by splitting the overall report period by the report interval. + -- For ending-balance reports, only the end date is significant. + -- Usually displayed as report columns. + , [PeriodicReportRow a] -- One row per account in the report. + , PeriodicReportRow a -- The grand totals row. The account name in this row is always empty. ) deriving (Show) type PeriodicReportRow a = - ( AccountName -- ^ A full account name. - , AccountName -- ^ Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed. - , Int -- ^ Indent level for displaying this account name in tree mode. 0, 1, 2... - , [a] -- ^ The data value for each subperiod. - , a -- ^ The total of this row's values. - , a -- ^ The average of this row's values. + ( AccountName -- A full account name. + , AccountName -- Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed. + , Int -- Indent level for displaying this account name in tree mode. 0, 1, 2... + , [a] -- The data value for each subperiod. + , a -- The total of this row's values. + , a -- The average of this row's values. ) diff --git a/hledger/Text/Tabular/AsciiWide.hs b/hledger-lib/Text/Tabular/AsciiWide.hs similarity index 100% rename from hledger/Text/Tabular/AsciiWide.hs rename to hledger-lib/Text/Tabular/AsciiWide.hs diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index cefa19d37..803ae8a40 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -113,8 +113,10 @@ library Hledger.Read.TimeclockReader Hledger.Reports Hledger.Reports.ReportOptions + Hledger.Reports.ReportTypes Hledger.Reports.BalanceHistoryReport Hledger.Reports.BalanceReport + Hledger.Reports.BudgetReport Hledger.Reports.EntriesReport Hledger.Reports.MultiBalanceReports Hledger.Reports.PostingsReport @@ -130,9 +132,8 @@ library Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat Text.Megaparsec.Compat + Text.Tabular.AsciiWide other-modules: - Hledger.Reports.BudgetReport - Hledger.Reports.ReportTypes Paths_hledger_lib default-language: Haskell2010 @@ -172,6 +173,7 @@ test-suite doctests , regex-tdfa , safe >=0.2 , split >=0.1 + , tabular >=0.2 , text >=1.2 , time >=1.5 , transformers >=0.2 @@ -229,6 +231,7 @@ test-suite doctests Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat Text.Megaparsec.Compat + Text.Tabular.AsciiWide Paths_hledger_lib default-language: Haskell2010 @@ -268,6 +271,7 @@ test-suite easytests , regex-tdfa , safe >=0.2 , split >=0.1 + , tabular >=0.2 , text >=1.2 , time >=1.5 , transformers >=0.2 @@ -323,6 +327,7 @@ test-suite easytests Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat Text.Megaparsec.Compat + Text.Tabular.AsciiWide Paths_hledger_lib default-language: Haskell2010 @@ -363,6 +368,7 @@ test-suite hunittests , split >=0.1 , test-framework , test-framework-hunit + , tabular >=0.2 , text >=1.2 , time >=1.5 , transformers >=0.2 @@ -418,5 +424,6 @@ test-suite hunittests Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat Text.Megaparsec.Compat + Text.Tabular.AsciiWide Paths_hledger_lib default-language: Haskell2010 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 51277fee0..2888a4b5c 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -63,6 +63,7 @@ dependencies: - regex-tdfa - safe >=0.2 - split >=0.1 +- tabular >=0.2 - text >=1.2 - time >=1.5 - transformers >=0.2 @@ -141,6 +142,7 @@ library: - Hledger.Utils.Tree - Hledger.Utils.UTF8IOCompat - Text.Megaparsec.Compat + - Text.Tabular.AsciiWide # other-modules: # - Ledger.Parser.Text diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 56e3b2172..64f79996c 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -53,7 +53,6 @@ module Hledger.Cli.CliOptions ( replaceNumericFlags, -- | For register: registerWidthsFromOpts, - maybeAccountNameDrop, -- | For balance: lineFormatFromOpts, @@ -584,11 +583,6 @@ registerWidthsFromOpts CliOpts{width_=Just s} = eof return (totalwidth, descwidth) --- | Drop leading components of accounts names as specified by --drop, but only in --flat mode. -maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName -maybeAccountNameDrop opts a | tree_ opts = a - | otherwise = accountNameDrop (drop_ opts) a - -- for balance, currently: -- | Parse the format option if provided, possibly returning an error, diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index 43ea65aa9..09d432458 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/hledger/Hledger/Cli/Commands/Balance.hs @@ -245,25 +245,23 @@ module Hledger.Cli.Commands.Balance ( ,multiBalanceReportAsCsv ,multiBalanceReportAsHtml ,multiBalanceReportHtmlRows - ,renderBalanceReportTable ,balanceReportAsTable + ,balanceReportTableAsText ,tests_Hledger_Cli_Commands_Balance ) where -import Data.Decimal import Data.List import Data.Maybe -import qualified Data.Map as Map +--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 Text.Tabular.AsciiWide import Hledger import Hledger.Cli.CliOptions @@ -330,15 +328,15 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do _ | boolopt "budget" rawopts -> do -- multi column budget report 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 + let budgetreport = dbg1 "budgetreport" $ budgetReport ropts assrt showunbudgeted reportspan d j + where + showunbudgeted = boolopt "show-unbudgeted" rawopts + assrt = not $ ignore_assertions_ $ inputopts_ opts render = case format of "csv" -> const $ error' "Sorry, CSV output is not yet implemented for this kind of report." -- TODO "html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO - _ -> multiBalanceReportWithBudgetAsText ropts budgetReport - writeOutput opts $ render report + _ -> budgetReportAsText ropts + writeOutput opts $ render budgetreport | otherwise -> do -- multi column balance report @@ -349,50 +347,7 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do _ -> multiBalanceReportAsText ropts writeOutput opts $ render report --- | Re-map account names to closest parent with periodic transaction from budget. --- Accounts that don't have suitable parent are either remapped to ":topAccount" --- or left as-is if --show-unbudgeted is provided. -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 ":") acctName -- TODO: --drop should not remove this - 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 } - --- | Select all periodic transactions from the given journal which --- match the requested report interval, and use them to generate --- budget transactions (like forecast transactions) in the specified --- report period (calculated in IO and passed in). -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 - - --- single-column balance reports +-- rendering single-column balance reports -- | Find the best commodity to convert to when asked to show the -- market value of this commodity on the given date. That is, the one @@ -522,7 +477,7 @@ renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) | otherwise = showMixedAmountWithoutPrice _ -> "" --- multi-column balance reports +-- rendering multi-column balance reports -- | Render a multi-column balance report as CSV. -- The CSV will always include the initial headings row, @@ -641,7 +596,7 @@ multiBalanceReportHtmlFootRow ropts (acct:rest) = multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String multiBalanceReportAsText opts r = printf "%s in %s:\n\n" desc (showDateSpan $ multiBalanceReportSpan r) - ++ renderBalanceReportTable opts tabl + ++ balanceReportTableAsText opts tabl where tabl = balanceReportAsTable opts r desc = case balancetype_ opts of @@ -649,129 +604,11 @@ multiBalanceReportAsText opts r = 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 - --- | Given two multi-column balance reports, the first representing a budget --- (target change amounts) and the second representing actual change amounts, --- render a budget report as plain text suitable for console output. --- The reports should have the same number of columns. -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 = - -- percentage of budget consumed is always computed in the cost basis - case (toCost actual, toCost budget) of - (Mixed [a1], Mixed [a2]) - | isReallyZeroAmount a1 -> Just 0 -- if there are no postings, we consumed 0% of budget - | 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 - - -- Combine a table of actual amounts and a table of budgeted amounts into - -- a single table of (Maybe actualamount, Maybe budgetamount) tuples. - -- The actual and budget table need not have the same account rows or date columns. - -- Every row and column from either table will appear in the combined table. - -- TODO better to combine the reports, not these tables which are just rendering helpers - 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] - -- combined account names - -- TODO Can't sort these or things will fall apart. - caccts = dbg2 "caccts" $ init $ (dbg2 "aaccts" $ filter (not . null) aaccts) `union` (dbg2 "baccts" baccts) - caccthdrs = T.Group NoLine $ map Header $ caccts - -- Actual column dates and budget column dates could be different. - -- TODO Can't easily combine these preserving correct order, will go wrong on monthly reports probably. - cdates = dbg2 "cdates" $ sort $ (dbg2 "adates" adates) `union` (dbg2 "bdates" bdates) - cdatehdrs = T.Group NoLine $ map Header cdates - -- corresponding rows of combined actual and/or budget amounts - crows = [ combineRow (actualRow a) (budgetRow a) | a <- caccts ] - -- totals row - addtotalrow | no_total_ opts = id - | otherwise = (+----+ (row "" $ combineRow (actualRow "") (budgetRow ""))) - -- helpers - 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 - --- | Given a table representing a multi-column balance report (for example, --- made using 'balanceReportAsTable'), render it in a format suitable for --- console output. -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 - -- | Build a 'Table' from a multi-column balance report. balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount balanceReportAsTable opts (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) = - addtotalrow $ Table + addtotalrow $ + Table (T.Group NoLine $ map Header accts) (T.Group NoLine $ map Header colheadings) (map rowvals items) @@ -796,10 +633,14 @@ balanceReportAsTable opts (MultiBalanceReport (colspans, items, (coltotals,tot,a ++ (if average_ opts && not (null coltotals) then [avg] else []) )) --- | Figure out the overall date span of a multicolumn balance report. -multiBalanceReportSpan :: MultiBalanceReport -> DateSpan -multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing -multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans) +-- | Given a table representing a multi-column balance report (for example, +-- made using 'balanceReportAsTable'), render it in a format suitable for +-- console output. +balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String +balanceReportTableAsText ropts = tableAsText ropts showamt + where + showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice + | otherwise = showMixedAmountOneLineWithoutPrice tests_Hledger_Cli_Commands_Balance = TestList diff --git a/hledger/Hledger/Cli/CompoundBalanceCommand.hs b/hledger/Hledger/Cli/CompoundBalanceCommand.hs index 73777faef..aea87afed 100644 --- a/hledger/Hledger/Cli/CompoundBalanceCommand.hs +++ b/hledger/Hledger/Cli/CompoundBalanceCommand.hs @@ -249,7 +249,7 @@ Balance Sheet compoundBalanceReportAsText :: ReportOpts -> CompoundBalanceReport -> String compoundBalanceReportAsText ropts (title, _colspans, subreports, (coltotals, grandtotal, grandavg)) = title ++ "\n\n" ++ - renderBalanceReportTable ropts bigtable' + balanceReportTableAsText ropts bigtable' where singlesubreport = length subreports == 1 bigtable = diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 57d3518fc..2034b5154 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -150,7 +150,6 @@ library Hledger.Cli.Commands.Stats Hledger.Cli.Commands.Tags Hledger.Cli.CompoundBalanceCommand - Text.Tabular.AsciiWide other-modules: Paths_hledger default-language: Haskell2010 diff --git a/hledger/package.yaml b/hledger/package.yaml index 468d7407a..e1ae437bd 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -131,7 +131,6 @@ library: - Hledger.Cli.Commands.Stats - Hledger.Cli.Commands.Tags - Hledger.Cli.CompoundBalanceCommand - - Text.Tabular.AsciiWide dependencies: - bytestring - containers diff --git a/tests/budget/budget.test b/tests/budget/budget.test index 33775f9ac..b4983c989 100644 --- a/tests/budget/budget.test +++ b/tests/budget/budget.test @@ -32,7 +32,7 @@ # 1. Test --budget switch $ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget -Balance changes in 2016/12/01-2016/12/03: +Budget performance in 2016/12/01-2016/12/03: || 2016/12/01 2016/12/02 2016/12/03 =======================++============================================================================== @@ -45,7 +45,7 @@ Balance changes in 2016/12/01-2016/12/03: # 2. --show-unbudgeted $ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget --show-unbudgeted -Balance changes in 2016/12/01-2016/12/03: +Budget performance in 2016/12/01-2016/12/03: || 2016/12/01 2016/12/02 2016/12/03 ==================++============================================================================== @@ -93,7 +93,7 @@ Balance changes in 2016/12/01-2016/12/03: assets:cash $ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget -Balance changes in 2016/12/01-2016/12/03: +Budget performance in 2016/12/01-2016/12/03: || 2016/12/01 2016/12/02 2016/12/03 =======================++===================================================================================== @@ -137,7 +137,7 @@ $ hledger -f- bal --budget # 5. With -D it selects the daily budget. # The budget is unbounded, so extends through the report period. $ hledger -f- bal --budget -D -Balance changes in 2018/01/01-2018/01/03: +Budget performance in 2018/01/01-2018/01/03: || 2018/01/01 2018/01/02 2018/01/03 ===++============================================================================== @@ -150,7 +150,7 @@ Balance changes in 2018/01/01-2018/01/03: # 6. And with -W it selects the weekly budget, defined by all weekly periodic transactions. $ hledger -f- bal --budget -W -Balance changes in 2018/01/01w01: +Budget performance in 2018/01/01w01: || 2018/01/01w01 ===++========================== @@ -182,7 +182,7 @@ Balance changes in 2018/01/01w01: (b) 1 $ hledger -f- bal --budget -D -Balance changes in 2018/01/01-2018/01/04: +Budget performance in 2018/01/01-2018/01/04: || 2018/01/01 2018/01/02 2018/01/03 2018/01/04 ================++======================================================================================================== @@ -212,7 +212,7 @@ Balance changes in 2018/01/01-2018/01/04: (a) 1 $ hledger -f- bal --budget -D -Balance changes in 2018/01/01-2018/01/04: +Budget performance in 2018/01/01-2018/01/04: || 2018/01/01 2018/01/02 2018/01/03 2018/01/04 ===++======================================================================================================== @@ -222,7 +222,7 @@ Balance changes in 2018/01/01-2018/01/04: # 9. A "from A to B" budget should not be included in a report beginning on B. $ hledger -f- bal --budget -D -b 2018/1/3 -Balance changes in 2018/01/03-2018/01/04: +Budget performance in 2018/01/03-2018/01/04: || 2018/01/03 2018/01/04 ===++==================================================== @@ -243,18 +243,18 @@ Balance changes in 2018/01/03-2018/01/04: # 10. accounts with non-zero budget should be shown by default # even if there are no actual transactions in the period, # or if the actual amount is zero. -# $ hledger -f- bal --budget -D date:2018/1/1-2018/1/3 -# Balance changes in 2018/01/01-2018/01/02: +$ hledger -f- bal --budget -D date:2018/1/1-2018/1/3 +Budget performance in 2018/01/01-2018/01/02: -# || 2018/01/01 2018/01/02 -# ===++==================================================== -# a || [ 1] [ 1] -# ---++---------------------------------------------------- -# || [ 1] [ 1] + || 2018/01/01 2018/01/02 +===++==================================================== + a || 0 [ 1] 0 [ 1] +---++---------------------------------------------------- + || 0 [ 1] 0 [ 1] # 11. With -E, zeroes are shown $ hledger -f- bal --budget -D date:2018/1/1-2018/1/3 -E -Balance changes in 2018/01/01-2018/01/02: +Budget performance in 2018/01/01-2018/01/02: || 2018/01/01 2018/01/02 ===++====================================================