diff --git a/hledger-lib/Hledger/Data.hs b/hledger-lib/Hledger/Data.hs index ad5406adf..812e1890d 100644 --- a/hledger-lib/Hledger/Data.hs +++ b/hledger-lib/Hledger/Data.hs @@ -10,6 +10,8 @@ functionality. This package re-exports all the Hledger.Data.* modules module Hledger.Data ( module Hledger.Data.Account, + module Hledger.Data.BalanceData, + module Hledger.Data.PeriodData, module Hledger.Data.AccountName, module Hledger.Data.Amount, module Hledger.Data.Balancing, @@ -36,6 +38,8 @@ where import Test.Tasty (testGroup) import Hledger.Data.Account +import Hledger.Data.BalanceData +import Hledger.Data.PeriodData import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Balancing @@ -58,7 +62,10 @@ import Hledger.Data.Types hiding (MixedAmountKey, Mixed) import Hledger.Data.Valuation tests_Data = testGroup "Data" [ - tests_AccountName + tests_Account + ,tests_AccountName + ,tests_BalanceData + ,tests_PeriodData ,tests_Amount ,tests_Balancing -- ,tests_Currency diff --git a/hledger-lib/Hledger/Data/Account.hs b/hledger-lib/Hledger/Data/Account.hs index b4c950cfd..cc0210278 100644 --- a/hledger-lib/Hledger/Data/Account.hs +++ b/hledger-lib/Hledger/Data/Account.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -11,8 +12,11 @@ account, and subaccounting-excluding and -including balances. module Hledger.Data.Account ( nullacct +, accountFromBalances +, accountFromPostings , accountsFromPostings , accountTree +, accountTreeFromBalanceAndNames , showAccounts , showAccountsBoringFlag , printAccounts @@ -20,6 +24,7 @@ module Hledger.Data.Account , parentAccounts , accountsLevels , mapAccounts +, mapPeriodData , anyAccounts , filterAccounts , sumAccounts @@ -27,38 +32,53 @@ module Hledger.Data.Account , clipAccountsAndAggregate , pruneAccounts , flattenAccounts +, mergeAccounts , accountSetDeclarationInfo , sortAccountNamesByDeclaration -, sortAccountTreeByAmount +, sortAccountTreeByDeclaration +, sortAccountTreeOn +-- -- * Tests +, tests_Account ) where +import Control.Applicative ((<|>)) import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap as IM import Data.List (find, sortOn) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -import Data.List.Extra (groupOn) +import Data.List.NonEmpty (NonEmpty(..), groupWith) import qualified Data.Map as M -import Data.Ord (Down(..)) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.These (These(..)) +import Data.Time (Day(..), fromGregorian) import Safe (headMay) import Text.Printf (printf) -import Hledger.Data.AccountName (expandAccountName, clipOrEllipsifyAccountName) +import Hledger.Data.BalanceData () +import Hledger.Data.PeriodData +import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Types +import Hledger.Utils -- deriving instance Show Account -instance Show Account where - show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)" - aname - (if aboring then "y" else "n" :: String) - anumpostings - (wbUnpack $ showMixedAmountB defaultFmt aebalance) - (wbUnpack $ showMixedAmountB defaultFmt aibalance) +instance Show a => Show (Account a) where + showsPrec d acct = + showParen (d > 10) $ + showString "Account " + . showString (T.unpack $ aname acct) + . showString " (boring:" + . showString (if aboring acct then "y" else "n") + . showString ", adata:" + . shows (adata acct) + . showChar ')' -instance Eq Account where +instance Eq (Account a) where (==) a b = aname a == aname b -- quick equality test for speed -- and -- [ aname a == aname b @@ -68,50 +88,73 @@ instance Eq Account where -- , aibalance a == aibalance b -- ] -nullacct = Account - { aname = "" +nullacct :: Account BalanceData +nullacct = accountFromBalances "" mempty + +-- | Construct an 'Account" from an account name and balances. Other fields are +-- left blank. +accountFromBalances :: AccountName -> PeriodData a -> Account a +accountFromBalances name bal = Account + { aname = name , adeclarationinfo = Nothing , asubs = [] , aparent = Nothing , aboring = False - , anumpostings = 0 - , aebalance = nullmixedamt - , aibalance = nullmixedamt + , adata = bal } --- | Derive 1. an account tree and 2. each account's total exclusive --- and inclusive changes from a list of postings. +-- | Derive 1. an account tree and 2. each account's total exclusive and +-- inclusive changes associated with dates from a list of postings and a +-- function for associating a date to each posting (usually representing the +-- start dates of report subperiods). -- This is the core of the balance command (and of *ledger). -- The accounts are returned as a list in flattened tree order, -- and also reference each other as a tree. -- (The first account is the root of the tree.) -accountsFromPostings :: [Posting] -> [Account] -accountsFromPostings ps = - let - summed = foldr (\p -> HM.insertWith addAndIncrement (paccount p) (1, pamount p)) mempty ps - where addAndIncrement (n, a) (m, b) = (n + m, a `maPlus` b) - acctstree = accountTree "root" $ HM.keys summed - acctswithebals = mapAccounts setnumpsebalance acctstree - where setnumpsebalance a = a{anumpostings=numps, aebalance=total} - where (numps, total) = HM.lookupDefault (0, nullmixedamt) (aname a) summed - acctswithibals = sumAccounts acctswithebals - acctswithparents = tieAccountParents acctswithibals - acctsflattened = flattenAccounts acctswithparents - in - acctsflattened +accountsFromPostings :: (Posting -> Maybe Day) -> [Posting] -> [Account BalanceData] +accountsFromPostings getPostingDate = flattenAccounts . accountFromPostings getPostingDate + +-- | Derive 1. an account tree and 2. each account's total exclusive +-- and inclusive changes associated with dates from a list of postings and a +-- function for associating a date to each posting (usually representing the +-- start dates of report subperiods). +-- This is the core of the balance command (and of *ledger). +-- The accounts are returned as a tree. +accountFromPostings :: (Posting -> Maybe Day) -> [Posting] -> Account BalanceData +accountFromPostings getPostingDate ps = + tieAccountParents . sumAccounts $ mapAccounts setBalance acctTree + where + -- The special name "..." is stored in the root of the tree + acctTree = accountTree "root" . HM.keys $ HM.delete "..." accountMap + setBalance a = a{adata = HM.lookupDefault mempty name accountMap} + where name = if aname a == "root" then "..." else aname a + accountMap = processPostings ps + + processPostings :: [Posting] -> HM.HashMap AccountName (PeriodData BalanceData) + processPostings = foldl' (flip processAccountName) mempty + where + processAccountName p = HM.alter (updateBalanceData p) (paccount p) + updateBalanceData p = Just + . insertPeriodData (getPostingDate p) (BalanceData (pamount p) nullmixedamt 1) + . fromMaybe mempty -- | Convert a list of account names to a tree of Account objects, --- with just the account names filled in. +-- with just the account names filled in and an empty balance. -- A single root account with the given name is added. -accountTree :: AccountName -> [AccountName] -> Account -accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m } +accountTree :: Monoid a => AccountName -> [AccountName] -> Account a +accountTree rootname = accountTreeFromBalanceAndNames rootname mempty + +-- | Convert a list of account names to a tree of Account objects, +-- with just the account names filled in. Each account is given the same +-- supplied balance. +-- A single root account with the given name is added. +accountTreeFromBalanceAndNames :: AccountName -> PeriodData a -> [AccountName] -> Account a +accountTreeFromBalanceAndNames rootname bals as = + (accountFromBalances rootname bals){ asubs=map (uncurry accountTree') $ M.assocs m } where T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName accountTree' a (T m') = - nullacct{ - aname=a - ,asubs=map (uncurry accountTree') $ M.assocs m' - } + (accountFromBalances a bals){ asubs=map (uncurry accountTree') $ M.assocs m' } -- | An efficient-to-build tree suggested by Cale Gibbard, probably -- better than accountNameTreeFrom. @@ -130,7 +173,7 @@ treeFromPaths = foldl' mergeTrees (T M.empty) . map treeFromPath -- | Tie the knot so all subaccounts' parents are set correctly. -tieAccountParents :: Account -> Account +tieAccountParents :: Account a -> Account a tieAccountParents = tie Nothing where tie parent a@Account{..} = a' @@ -138,35 +181,50 @@ tieAccountParents = tie Nothing a' = a{aparent=parent, asubs=map (tie (Just a')) asubs} -- | Get this account's parent accounts, from the nearest up to the root. -parentAccounts :: Account -> [Account] +parentAccounts :: Account a -> [Account a] parentAccounts Account{aparent=Nothing} = [] parentAccounts Account{aparent=Just a} = a:parentAccounts a -- | List the accounts at each level of the account tree. -accountsLevels :: Account -> [[Account]] +accountsLevels :: Account a -> [[Account a]] accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[]) -- | Map a (non-tree-structure-modifying) function over this and sub accounts. -mapAccounts :: (Account -> Account) -> Account -> Account +mapAccounts :: (Account a -> Account a) -> Account a -> Account a mapAccounts f a = f a{asubs = map (mapAccounts f) $ asubs a} +-- | Apply a function to all 'PeriodData' within this and sub accounts. +mapPeriodData :: (PeriodData a -> PeriodData a) -> Account a -> Account a +mapPeriodData f = mapAccounts (\a -> a{adata = f $ adata a}) + -- | Is the predicate true on any of this account or its subaccounts ? -anyAccounts :: (Account -> Bool) -> Account -> Bool +anyAccounts :: (Account a -> Bool) -> Account a -> Bool anyAccounts p a | p a = True | otherwise = any (anyAccounts p) $ asubs a --- | Add subaccount-inclusive balances to an account tree. -sumAccounts :: Account -> Account -sumAccounts a - | null $ asubs a = a{aibalance=aebalance a} - | otherwise = a{aibalance=ibal, asubs=subs} +-- | Is the predicate true on all of this account and its subaccounts ? +allAccounts :: (Account a -> Bool) -> Account a -> Bool +allAccounts p a + | not (p a) = False + | otherwise = all (allAccounts p) $ asubs a + +-- | Recalculate all the subaccount-inclusive balances in this tree. +sumAccounts :: Account BalanceData -> Account BalanceData +sumAccounts a = a{asubs = subs, adata = setInclusiveBalances $ adata a} where subs = map sumAccounts $ asubs a - ibal = maSum $ aebalance a : map aibalance subs + subtotals = foldMap adata subs + + setInclusiveBalances :: PeriodData BalanceData -> PeriodData BalanceData + setInclusiveBalances = mergePeriodData onlyChildren noChildren combineChildren subtotals + + combineChildren children this = this {bdincludingsubs = bdexcludingsubs this <> bdincludingsubs children} + onlyChildren children = mempty{bdincludingsubs = bdincludingsubs children} + noChildren this = this {bdincludingsubs = bdexcludingsubs this} -- | Remove all subaccounts below a certain depth. -clipAccounts :: Int -> Account -> Account +clipAccounts :: Int -> Account a -> Account a clipAccounts 0 a = a{asubs=[]} clipAccounts d a = a{asubs=subs} where @@ -175,13 +233,14 @@ clipAccounts d a = a{asubs=subs} -- | Remove subaccounts below the specified depth, aggregating their balance at the depth limit -- (accounts at the depth limit will have any sub-balances merged into their exclusive balance). -- If the depth is Nothing, return the original accounts -clipAccountsAndAggregate :: DepthSpec -> [Account] -> [Account] +clipAccountsAndAggregate :: Monoid a => DepthSpec -> [Account a] -> [Account a] clipAccountsAndAggregate (DepthSpec Nothing []) as = as -clipAccountsAndAggregate d as = combined +clipAccountsAndAggregate depthSpec as = combined where - clipped = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as] - combined = [a{aebalance=maSum $ map aebalance same} - | same@(a:_) <- groupOn aname clipped] + clipped = [a{aname=clipOrEllipsifyAccountName depthSpec $ aname a} | a <- as] + combined = [a{adata=foldMap adata same} + | same@(a:|_) <- groupWith aname clipped] + {- test cases, assuming d=1: @@ -211,7 +270,7 @@ combined: [assets 2 2] -} -- | Remove all leaf accounts and subtrees matching a predicate. -pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account +pruneAccounts :: (Account a -> Bool) -> Account a -> Maybe (Account a) pruneAccounts p = headMay . prune where prune a @@ -224,33 +283,47 @@ pruneAccounts p = headMay . prune -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the -- tree's structure remains intact and can still be used. It's a tree/list! -flattenAccounts :: Account -> [Account] +flattenAccounts :: Account a -> [Account a] flattenAccounts a = squish a [] where squish a' as = a' : Prelude.foldr squish as (asubs a') -- | Filter an account tree (to a list). -filterAccounts :: (Account -> Bool) -> Account -> [Account] +filterAccounts :: (Account a -> Bool) -> Account a -> [Account a] filterAccounts p a | p a = a : concatMap (filterAccounts p) (asubs a) | otherwise = concatMap (filterAccounts p) (asubs a) --- | Sort each group of siblings in an account tree by inclusive amount, --- so that the accounts with largest normal balances are listed first. --- The provided normal balance sign determines whether normal balances --- are negative or positive, affecting the sort order. Ie, --- if balances are normally negative, then the most negative balances --- sort first, and vice versa. -sortAccountTreeByAmount :: NormalSign -> Account -> Account -sortAccountTreeByAmount normalsign = mapAccounts $ \a -> a{asubs=sortSubs $ asubs a} +-- | Merge two account trees and their subaccounts. +-- +-- This assumes that the top-level 'Account's have the same name. +mergeAccounts :: Account a -> Account b -> Account (These a b) +mergeAccounts a = tieAccountParents . merge a where - sortSubs = case normalsign of - NormallyPositive -> sortOn (\a -> (Down $ amt a, aname a)) - NormallyNegative -> sortOn (\a -> (amt a, aname a)) - amt = mixedAmountStripCosts . aibalance + merge acct1 acct2 = acct1 + { adeclarationinfo = adeclarationinfo acct1 <|> adeclarationinfo acct2 + , aparent = Nothing + , aboring = aboring acct1 && aboring acct2 + , adata = mergeBalances (adata acct1) (adata acct2) + , asubs = mergeSubs (sortOn aname $ asubs acct1) (sortOn aname $ asubs acct2) + } + + mergeSubs (x:xs) (y:ys) = case compare (aname x) (aname y) of + EQ -> merge x y : mergeSubs xs ys + LT -> fmap This x : mergeSubs xs (y:ys) + GT -> fmap That y : mergeSubs (x:xs) ys + mergeSubs xs [] = map (fmap This) xs + mergeSubs [] ys = map (fmap That) ys + + mergeBalances = mergePeriodData This That These + +-- | Sort each group of siblings in an account tree by projecting through +-- a provided function. +sortAccountTreeOn :: Ord b => (Account a -> b) -> Account a -> Account a +sortAccountTreeOn f = mapAccounts $ \a -> a{asubs=sortOn f $ asubs a} -- | Add extra info for this account derived from the Journal's -- account directives, if any (comment, tags, declaration order..). -accountSetDeclarationInfo :: Journal -> Account -> Account +accountSetDeclarationInfo :: Journal -> Account a -> Account a accountSetDeclarationInfo j a@Account{..} = a{ adeclarationinfo=lookup aname $ jdeclaredaccounts j } @@ -271,14 +344,13 @@ sortAccountNamesByDeclaration j keepparents as = flattenAccounts $ -- convert to an account list sortAccountTreeByDeclaration $ -- sort by declaration order (and name) mapAccounts (accountSetDeclarationInfo j) $ -- add declaration order info - accountTree "root" -- convert to an account tree - as + (accountTree "root" as :: Account ()) -- convert to an account tree -- | Sort each group of siblings in an account tree by declaration order, then account name. -- So each group will contain first the declared accounts, -- in the same order as their account directives were parsed, -- and then the undeclared accounts, sorted by account name. -sortAccountTreeByDeclaration :: Account -> Account +sortAccountTreeByDeclaration :: Account a -> Account a sortAccountTreeByDeclaration a | null $ asubs a = a | otherwise = a{asubs= @@ -286,26 +358,37 @@ sortAccountTreeByDeclaration a map sortAccountTreeByDeclaration $ asubs a } -accountDeclarationOrderAndName :: Account -> (Int, AccountName) +accountDeclarationOrderAndName :: Account a -> (Int, AccountName) accountDeclarationOrderAndName a = (adeclarationorder', aname a) where adeclarationorder' = maybe maxBound adideclarationorder $ adeclarationinfo a -- | Search an account list by name. -lookupAccount :: AccountName -> [Account] -> Maybe Account +lookupAccount :: AccountName -> [Account a] -> Maybe (Account a) lookupAccount a = find ((==a).aname) -- debug helpers -printAccounts :: Account -> IO () +printAccounts :: Show a => Account a -> IO () printAccounts = putStrLn . showAccounts +showAccounts :: Show a => Account a -> String showAccounts = unlines . map showAccountDebug . flattenAccounts showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts -showAccountDebug a = printf "%-25s %4s %4s %s" +showAccountDebug a = printf "%-25s %s %4s" (aname a) - (wbUnpack . showMixedAmountB defaultFmt $ aebalance a) - (wbUnpack . showMixedAmountB defaultFmt $ aibalance a) (if aboring a then "b" else " " :: String) + (show $ adata a) + + +tests_Account = testGroup "Account" [ + testGroup "accountFromPostings" [ + testCase "no postings, no days" $ + accountFromPostings undefined [] @?= accountTree "root" [] + ,testCase "no postings, only 2000-01-01" $ + allAccounts (all (\d -> (ModifiedJulianDay $ toInteger d) == fromGregorian 2000 01 01) . IM.keys . pdperiods . adata) + (accountFromPostings undefined []) @? "Not all adata have exactly 2000-01-01" + ] + ] diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index ee196c722..39c320c2a 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -135,6 +135,7 @@ module Hledger.Data.Amount ( divideMixedAmount, multiplyMixedAmount, averageMixedAmounts, + sumAndAverageMixedAmounts, isNegativeAmount, isNegativeMixedAmount, mixedAmountIsZero, @@ -851,8 +852,14 @@ transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount transformMixedAmount f = mapMixedAmountUnsafe (transformAmount f) -- | Calculate the average of some mixed amounts. -averageMixedAmounts :: [MixedAmount] -> MixedAmount -averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` maSum as +averageMixedAmounts :: Foldable f => f MixedAmount -> MixedAmount +averageMixedAmounts = snd . sumAndAverageMixedAmounts + +-- | Calculate the sum and average of some mixed amounts. +sumAndAverageMixedAmounts :: Foldable f => f MixedAmount -> (MixedAmount, MixedAmount) +sumAndAverageMixedAmounts amts = (total, fromIntegral nAmts `divideMixedAmount` total) + where + (nAmts, total) = foldl' (\(n, a) b -> (n + 1, maPlus a b)) (0 :: Int, nullmixedamt) amts -- | Is this mixed amount negative, if we can tell that unambiguously? -- Ie when normalised, are all individual commodity amounts negative ? @@ -1039,9 +1046,16 @@ mixedAmountSetStyles = styleAmounts instance HasAmounts MixedAmount where styleAmounts styles = mapMixedAmountUnsafe (styleAmounts styles) -instance HasAmounts Account where - styleAmounts styles acct@Account{aebalance,aibalance} = - acct{aebalance=styleAmounts styles aebalance, aibalance=styleAmounts styles aibalance} +instance HasAmounts BalanceData where + styleAmounts styles balance@BalanceData{bdexcludingsubs,bdincludingsubs} = + balance{bdexcludingsubs=styleAmounts styles bdexcludingsubs, bdincludingsubs=styleAmounts styles bdincludingsubs} + +instance HasAmounts a => HasAmounts (PeriodData a) where + styleAmounts styles = fmap (styleAmounts styles) + +instance HasAmounts a => HasAmounts (Account a) where + styleAmounts styles acct@Account{adata} = + acct{adata = styleAmounts styles <$> adata} -- | Reset each individual amount's display style to the default. mixedAmountUnstyled :: MixedAmount -> MixedAmount diff --git a/hledger-lib/Hledger/Data/BalanceData.hs b/hledger-lib/Hledger/Data/BalanceData.hs new file mode 100644 index 000000000..113dcaec3 --- /dev/null +++ b/hledger-lib/Hledger/Data/BalanceData.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-| + + +A 'BalanceData is a data type tracking a number of postings, exclusive, and inclusive balance +for given date ranges. + +-} +module Hledger.Data.BalanceData +( mapBalanceData +, opBalanceData + +, tests_BalanceData +) where + + +import Test.Tasty (testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +import Hledger.Data.Amount +import Hledger.Data.Types + + +instance Show BalanceData where + showsPrec d (BalanceData e i n) = + showParen (d > 10) $ + showString "BalanceData" + . showString "{ bdexcludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt e)) + . showString ", bdincludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt i)) + . showString ", bdnumpostings = " . shows n + . showChar '}' + +instance Semigroup BalanceData where + BalanceData e i n <> BalanceData e' i' n' = BalanceData (maPlus e e') (maPlus i i') (n + n') + +instance Monoid BalanceData where + mempty = BalanceData nullmixedamt nullmixedamt 0 + +-- | Apply an operation to both 'MixedAmount' in an 'BalanceData'. +mapBalanceData :: (MixedAmount -> MixedAmount) -> BalanceData -> BalanceData +mapBalanceData f a = a{bdexcludingsubs = f $ bdexcludingsubs a, bdincludingsubs = f $ bdincludingsubs a} + +-- | Merge two 'BalanceData', using the given operation to combine their amounts. +opBalanceData :: (MixedAmount -> MixedAmount -> MixedAmount) -> BalanceData -> BalanceData -> BalanceData +opBalanceData f a b = a{bdexcludingsubs = f (bdexcludingsubs a) (bdexcludingsubs b), bdincludingsubs = f (bdincludingsubs a) (bdincludingsubs b)} + + +-- tests + +tests_BalanceData = testGroup "BalanceData" [ + + testCase "opBalanceData maPlus" $ do + opBalanceData maPlus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0) + @?= BalanceData (mixed [usd 4]) (mixed [usd 6]) 5, + + testCase "opBalanceData maMinus" $ do + opBalanceData maMinus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0) + @?= BalanceData (mixed [usd (-2)]) (mixed [usd (-2)]) 5 + ] diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 013ca9369..f905743de 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -56,7 +56,6 @@ module Hledger.Data.Journal ( journalAccountNamesDeclared, journalAccountNamesDeclaredOrUsed, journalAccountNamesDeclaredOrImplied, - journalLeafAccountNamesDeclared, journalAccountNames, journalLeafAccountNames, journalAccountNameTree, @@ -463,11 +462,6 @@ journalAccountNamesImplied = expandAccountNames . journalAccountNamesUsed journalAccountNamesDeclared :: Journal -> [AccountName] journalAccountNamesDeclared = nubSort . map fst . jdeclaredaccounts --- | Sorted unique account names declared by account directives in this journal, --- which have no children. -journalLeafAccountNamesDeclared :: Journal -> [AccountName] -journalLeafAccountNamesDeclared = treeLeaves . accountNameTreeFrom . journalAccountNamesDeclared - -- | Sorted unique account names declared by account directives or posted to -- by transactions in this journal. journalAccountNamesDeclaredOrUsed :: Journal -> [AccountName] diff --git a/hledger-lib/Hledger/Data/Json.hs b/hledger-lib/Hledger/Data/Json.hs index 449b1b3f3..b95762056 100644 --- a/hledger-lib/Hledger/Data/Json.hs +++ b/hledger-lib/Hledger/Data/Json.hs @@ -22,9 +22,11 @@ import Data.Aeson.Encode.Pretty (Config(..), Indent(..), NumberFormat( --import Data.Aeson.TH import qualified Data.ByteString.Lazy as BL import Data.Decimal (DecimalRaw(..), roundTo) +import qualified Data.IntMap as IM import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB +import Data.Time (Day(..)) import Text.Megaparsec (Pos, SourcePos, mkPos, unPos) import Hledger.Data.Types @@ -155,24 +157,27 @@ instance ToJSON TimeclockCode instance ToJSON TimeclockEntry instance ToJSON Journal -instance ToJSON Account where +instance ToJSON BalanceData +instance ToJSON a => ToJSON (PeriodData a) where + toJSON a = object + [ "pdpre" .= pdpre a + , "pdperiods" .= map (\(d, x) -> (ModifiedJulianDay (toInteger d), x)) (IM.toList $ pdperiods a) + ] + +instance ToJSON a => ToJSON (Account a) where toJSON = object . accountKV toEncoding = pairs . mconcat . accountKV accountKV :: #if MIN_VERSION_aeson(2,2,0) - KeyValue e kv + (KeyValue e kv, ToJSON a) #else - KeyValue kv + (KeyValue kv, ToJSON a) #endif - => Account -> [kv] + => Account a -> [kv] accountKV a = [ "aname" .= aname a , "adeclarationinfo" .= adeclarationinfo a - , "aebalance" .= aebalance a - , "aibalance" .= aibalance a - , "anumpostings" .= anumpostings a - , "aboring" .= aboring a -- To avoid a cycle, show just the parent account's name -- in a dummy field. When re-parsed, there will be no parent. , "aparent_" .= maybe "" aname (aparent a) @@ -181,7 +186,9 @@ accountKV a = -- The actual subaccounts (and their subs..), making a (probably highly redundant) tree -- ,"asubs" .= asubs a -- Omit the actual subaccounts - , "asubs" .= ([]::[Account]) + , "asubs" .= ([]::[Account BalanceData]) + , "aboring" .= aboring a + , "adata" .= adata a ] instance ToJSON Ledger @@ -215,10 +222,17 @@ instance FromJSON PostingType instance FromJSON Posting instance FromJSON Transaction instance FromJSON AccountDeclarationInfo + +instance FromJSON BalanceData +instance FromJSON a => FromJSON (PeriodData a) where + parseJSON = withObject "PeriodData" $ \v -> PeriodData + <$> v .: "pdpre" + <*> (IM.fromList . map (\(d, x) -> (fromInteger $ toModifiedJulianDay d, x)) <$> v .: "pdperiods") + -- XXX The ToJSON instance replaces subaccounts with just names. -- Here we should try to make use of those to reconstruct the -- parent-child relationships. -instance FromJSON Account +instance FromJSON a => FromJSON (Account a) -- Decimal, various attempts -- diff --git a/hledger-lib/Hledger/Data/Ledger.hs b/hledger-lib/Hledger/Data/Ledger.hs index ca5cbd4fe..1c3d30d01 100644 --- a/hledger-lib/Hledger/Data/Ledger.hs +++ b/hledger-lib/Hledger/Data/Ledger.hs @@ -32,6 +32,7 @@ import Test.Tasty (testGroup) import Test.Tasty.HUnit ((@?=), testCase) import Hledger.Data.Types import Hledger.Data.Account +import Hledger.Data.Dates (nulldate) import Hledger.Data.Journal import Hledger.Query @@ -61,7 +62,8 @@ ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as} (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) j' = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude filterJournalPostings q' j - as = accountsFromPostings $ journalPostings j' + -- Ledger does not use date-separated balances, so dates are left empty + as = accountsFromPostings (const $ Just nulldate) $ journalPostings j' j'' = filterJournalPostings depthq j' -- | List a ledger's account names. @@ -69,21 +71,21 @@ ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . map aname . laccounts -- | Get the named account from a ledger. -ledgerAccount :: Ledger -> AccountName -> Maybe Account +ledgerAccount :: Ledger -> AccountName -> Maybe (Account BalanceData) ledgerAccount l a = lookupAccount a $ laccounts l -- | Get this ledger's root account, which is a dummy "root" account -- above all others. This should always be first in the account list, -- if somehow not this returns a null account. -ledgerRootAccount :: Ledger -> Account +ledgerRootAccount :: Ledger -> Account BalanceData ledgerRootAccount = headDef nullacct . laccounts -- | List a ledger's top-level accounts (the ones below the root), in tree order. -ledgerTopAccounts :: Ledger -> [Account] +ledgerTopAccounts :: Ledger -> [Account BalanceData] ledgerTopAccounts = asubs . headDef nullacct . laccounts -- | List a ledger's bottom-level (subaccount-less) accounts, in tree order. -ledgerLeafAccounts :: Ledger -> [Account] +ledgerLeafAccounts :: Ledger -> [Account BalanceData] ledgerLeafAccounts = filter (null.asubs) . laccounts -- | List a ledger's postings, in the order parsed. diff --git a/hledger-lib/Hledger/Data/PeriodData.hs b/hledger-lib/Hledger/Data/PeriodData.hs new file mode 100644 index 000000000..13741163d --- /dev/null +++ b/hledger-lib/Hledger/Data/PeriodData.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-| + + +Data values for zero or more report periods, and for the pre-report period. +Report periods are assumed to be contiguous, and represented only by start dates +(as keys of an IntMap). + +-} +module Hledger.Data.PeriodData +( periodDataFromList + +, lookupPeriodData +, insertPeriodData +, opPeriodData +, mergePeriodData +, padPeriodData + +, tests_PeriodData +) where + +import Data.Foldable1 (Foldable1(..)) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif +import Data.Time (Day(..), fromGregorian) + +import Test.Tasty (testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +import Hledger.Data.Amount +import Hledger.Data.Types + + +instance Show a => Show (PeriodData a) where + showsPrec d (PeriodData h ds) = + showParen (d > 10) $ + showString "PeriodData" + . showString "{ pdpre = " . shows h + . showString ", pdperiods = " + . showString "fromList " . shows (map (\(day, x) -> (ModifiedJulianDay $ toInteger day, x)) $ IM.toList ds) + . showChar '}' + +instance Foldable PeriodData where + foldr f z (PeriodData h as) = foldr f (f h z) as + foldl f z (PeriodData h as) = foldl f (f z h) as + foldl' f z (PeriodData h as) = let fzh = f z h in fzh `seq` foldl' f fzh as + +instance Foldable1 PeriodData where + foldrMap1 f g (PeriodData h as) = foldr g (f h) as + foldlMap1 f g (PeriodData h as) = foldl g (f h) as + foldlMap1' f g (PeriodData h as) = let fh = f h in fh `seq` foldl' g fh as + +instance Traversable PeriodData where + traverse f (PeriodData h as) = liftA2 PeriodData (f h) $ traverse f as + +-- | The Semigroup instance for 'AccountBalance' will simply take the union of +-- keys in the date map section. This may not be the result you want if the +-- keys are not identical. +instance Semigroup a => Semigroup (PeriodData a) where + PeriodData h1 as1 <> PeriodData h2 as2 = PeriodData (h1 <> h2) $ IM.unionWith (<>) as1 as2 + +instance Monoid a => Monoid (PeriodData a) where + mempty = PeriodData mempty mempty + +-- | Construct an 'PeriodData' from a list. +periodDataFromList :: a -> [(Day, a)] -> PeriodData a +periodDataFromList h = PeriodData h . IM.fromList . map (\(d, a) -> (fromInteger $ toModifiedJulianDay d, a)) + +-- | Get account balance information to the period containing a given 'Day'. +lookupPeriodData :: Day -> PeriodData a -> a +lookupPeriodData d (PeriodData h as) = + maybe h snd $ IM.lookupLE (fromInteger $ toModifiedJulianDay d) as + +-- | Add account balance information to the appropriate location in 'PeriodData'. +insertPeriodData :: Semigroup a => Maybe Day -> a -> PeriodData a -> PeriodData a +insertPeriodData mday b balances = case mday of + Nothing -> balances{pdpre = pdpre balances <> b} + Just day -> balances{pdperiods = IM.insertWith (<>) (fromInteger $ toModifiedJulianDay day) b $ pdperiods balances} + +-- | Merges two 'PeriodData', using the given operation to combine their balance information. +-- +-- This will drop keys if they are not present in both 'PeriodData'. +opPeriodData :: (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c +opPeriodData f (PeriodData h1 as1) (PeriodData h2 as2) = + PeriodData (f h1 h2) $ IM.intersectionWith f as1 as2 + +-- | Merges two 'PeriodData', using the given operations for balance +-- information only in the first, only in the second, or in both +-- 'PeriodData', respectively. +mergePeriodData :: (a -> c) -> (b -> c) -> (a -> b -> c) + -> PeriodData a -> PeriodData b -> PeriodData c +mergePeriodData only1 only2 f = \(PeriodData h1 as1) (PeriodData h2 as2) -> + PeriodData (f h1 h2) $ merge as1 as2 + where + merge = IM.mergeWithKey (\_ x y -> Just $ f x y) (fmap only1) (fmap only2) + +-- | Pad out the datemap of an 'PeriodData' so that every key from a set is present. +padPeriodData :: Monoid a => IS.IntSet -> PeriodData a -> PeriodData a +padPeriodData keys bal = bal{pdperiods = pdperiods bal <> IM.fromSet (const mempty) keys} + + +-- tests + +tests_PeriodData = + let + dayMap = periodDataFromList (mixed [usd 1]) [(fromGregorian 2000 01 01, mixed [usd 2]), (fromGregorian 2004 02 28, mixed [usd 3])] + dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])] + in testGroup "PeriodData" [ + + testCase "periodDataFromList" $ do + length dayMap @?= 3, + + testCase "Semigroup instance" $ do + dayMap <> dayMap @?= dayMap2, + + testCase "Monoid instance" $ do + dayMap <> mempty @?= dayMap + ] diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 177a276be..1196197c1 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -18,6 +18,7 @@ For more detailed documentation on each type, see the corresponding modules. -- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -39,6 +40,7 @@ import Data.Bifunctor (first) import Data.Decimal (Decimal, DecimalRaw(..)) import Data.Default (Default(..)) import Data.Functor (($>)) +import qualified Data.IntMap.Strict as IM import Data.List (intercalate, sortBy) --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html --Note: You should use Data.Map.Strict instead of this module if: @@ -733,20 +735,36 @@ nullaccountdeclarationinfo = AccountDeclarationInfo { ,adisourcepos = SourcePos "" (mkPos 1) (mkPos 1) } --- | An account, with its balances, parent/subaccount relationships, etc. --- Only the name is required; the other fields are added when needed. -data Account = Account { - aname :: AccountName -- ^ this account's full name +-- | An account within a hierarchy, with references to its parent +-- and subaccounts if any, and with per-report-period data of type 'a'. +-- Only the name is required; the other fields may or may not be present. +data Account a = Account { + aname :: AccountName -- ^ full name ,adeclarationinfo :: Maybe AccountDeclarationInfo -- ^ optional extra info from account directives -- relationships in the tree - ,asubs :: [Account] -- ^ this account's sub-accounts - ,aparent :: Maybe Account -- ^ parent account - ,aboring :: Bool -- ^ used in the accounts report to label elidable parents - -- balance information - ,anumpostings :: Int -- ^ the number of postings to this account - ,aebalance :: MixedAmount -- ^ this account's balance, excluding subaccounts - ,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts - } deriving (Generic) + ,asubs :: [Account a] -- ^ subaccounts + ,aparent :: Maybe (Account a) -- ^ parent account + ,aboring :: Bool -- ^ used in some reports to indicate elidable accounts + ,adata :: PeriodData a -- ^ associated data per report period + } deriving (Generic, Functor) + +-- | Data values for zero or more report periods, and for the pre-report period. +-- Report periods are assumed to be contiguous, and represented only by start dates +-- (as keys of an IntMap). XXX how does that work, again ? +data PeriodData a = PeriodData { + pdpre :: a -- ^ data from the pre-report period (e.g. historical balances) + ,pdperiods :: IM.IntMap a -- ^ data for the periods + } deriving (Eq, Functor, Generic) + +-- | Data that's useful in "balance" reports: +-- subaccount-exclusive and -inclusive amounts, +-- typically representing either a balance change or an end balance; +-- and a count of postings. +data BalanceData = BalanceData { + bdexcludingsubs :: MixedAmount -- ^ balance data excluding subaccounts + ,bdincludingsubs :: MixedAmount -- ^ balance data including subaccounts + ,bdnumpostings :: Int -- ^ the number of postings + } deriving (Eq, Generic) -- | Whether an account's balance is normally a positive number (in -- accounting terms, a debit balance) or a negative number (credit balance). @@ -761,7 +779,7 @@ data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Eq) -- account is the root of the tree and always exists. data Ledger = Ledger { ljournal :: Journal - ,laccounts :: [Account] + ,laccounts :: [Account BalanceData] } deriving (Generic) instance NFData AccountAlias diff --git a/hledger-lib/Hledger/Reports/BudgetReport.hs b/hledger-lib/Hledger/Reports/BudgetReport.hs index 947c5b18e..47c2e043f 100644 --- a/hledger-lib/Hledger/Reports/BudgetReport.hs +++ b/hledger-lib/Hledger/Reports/BudgetReport.hs @@ -9,23 +9,22 @@ module Hledger.Reports.BudgetReport ( BudgetReportRow, BudgetReport, budgetReport, - -- * Helpers - combineBudgetAndActual, -- * Tests tests_BudgetReport ) where import Control.Applicative ((<|>)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Data.List (find, partition, maximumBy, intercalate) +import Control.Monad ((>=>)) +import Data.Bifunctor (bimap) +import Data.Foldable (toList) +import Data.List (find, maximumBy, intercalate) import Data.List.Extra (nubSort) -import Data.Maybe (fromMaybe, isJust) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T +import Data.These (These(..), these) import Safe (minimumDef) import Hledger.Data @@ -33,8 +32,6 @@ import Hledger.Utils import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.MultiBalanceReport -import Data.Ord (comparing) -import Control.Monad ((>=>)) -- All MixedAmounts: type BudgetGoal = Change @@ -69,7 +66,9 @@ budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport -- Budget report demands ALTree mode to ensure subaccounts and subaccount budgets are properly handled -- and that reports with and without --empty make sense when compared side by side ropts = (_rsReportOpts rspec){ accountlistmode_ = ALTree } + -- ropts = _rsReportOpts rspec showunbudgeted = empty_ ropts + budgetedaccts = dbg3 "budgetedacctsinperiod" $ S.fromList $ @@ -78,21 +77,59 @@ budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport concatMap tpostings $ concatMap (\pt -> runPeriodicTransaction False pt reportspan) $ jperiodictxns j + actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j priceoracle = journalPriceOracle (infer_prices_ ropts) j - budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) = - dbg5 "budgetgoalreport" $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} budgetj priceoracle mempty - budgetedacctsseen = S.fromList $ map prrFullName budgetgoalitems - actualreport@(PeriodicReport actualspans _ _) = - dbg5 "actualreport" $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} actualj priceoracle budgetedacctsseen - budgetgoalreport' - -- If no interval is specified: - -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; - -- it should be safe to replace it with the latter, so they combine well. - | interval_ ropts == NoInterval = PeriodicReport actualspans budgetgoalitems budgetgoaltotals - | otherwise = budgetgoalreport - budgetreport = combineBudgetAndActual ropts j budgetgoalreport' actualreport + + (_, actualspans) = dbg5 "actualspans" $ reportSpan actualj rspec + (_, budgetspans) = dbg5 "budgetspans" $ reportSpan budgetj rspec + allspans = case interval_ ropts of + -- If no interval is specified: + -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; + -- it should be safe to replace it with the latter, so they combine well. + NoInterval -> actualspans + _ -> nubSort . filter (/= nulldatespan) $ actualspans ++ budgetspans + + actualps = dbg5 "actualps" $ getPostings rspec actualj priceoracle reportspan + budgetps = dbg5 "budgetps" $ getPostings rspec budgetj priceoracle reportspan + + actualAcct = dbg5 "actualAcct" $ generateMultiBalanceAccount rspec actualj priceoracle actualspans actualps + budgetAcct = dbg5 "budgetAcct" $ generateMultiBalanceAccount rspec budgetj priceoracle budgetspans budgetps + + combinedAcct = dbg5 "combinedAcct" $ if null budgetps + -- If no budget postings, just use actual account, to avoid unnecssary budget zeros + then This <$> actualAcct + else mergeAccounts actualAcct budgetAcct + + budgetreport = generateBudgetReport ropts allspans combinedAcct + +-- | Lay out a set of postings grouped by date span into a regular matrix with rows +-- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport +-- from the columns. +generateBudgetReport :: ReportOpts -> [DateSpan] -> Account (These BalanceData BalanceData) -> BudgetReport +generateBudgetReport = generatePeriodicReport makeBudgetReportRow treeActualBalance flatActualBalance + where + treeActualBalance = these bdincludingsubs (const nullmixedamt) (const . bdincludingsubs) + flatActualBalance = fromMaybe nullmixedamt . fst + +-- | Build a report row. +-- +-- Calculate the column totals. These are always the sum of column amounts. +makeBudgetReportRow :: ReportOpts -> (BalanceData -> MixedAmount) + -> a -> Account (These BalanceData BalanceData) -> PeriodicReportRow a BudgetCell +makeBudgetReportRow ropts balance = + makePeriodicReportRow (Just nullmixedamt, Nothing) avg ropts (theseToMaybe . bimap balance balance) + where + avg xs = ((actualtotal, budgettotal), (actualavg, budgetavg)) + where + (actuals, budgets) = unzip $ toList xs + (actualtotal, actualavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes actuals + (budgettotal, budgetavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes budgets + + theseToMaybe (This a) = (Just a, Nothing) + theseToMaybe (That b) = (Just nullmixedamt, Just b) + theseToMaybe (These a b) = (Just a, Just b) -- | Use all (or all matched by --budget's argument) periodic transactions in the journal -- to generate budget goal transactions in the specified date span (and before, to support @@ -179,81 +216,6 @@ journalWithBudgetAccountNames budgetedaccts showunbudgeted j = budgetedparent = find (`S.member` budgetedaccts) $ parentAccountNames a u = unbudgetedAccountName --- | 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 :: ReportOpts -> Journal -> MultiBalanceReport -> MultiBalanceReport -> BudgetReport -combineBudgetAndActual ropts j - (PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ budgettots budgetgrandtot budgetgrandavg)) - (PeriodicReport actualperiods actualrows (PeriodicReportRow _ actualtots actualgrandtot actualgrandavg)) = - PeriodicReport periods combinedrows totalrow - where - periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods - - -- first, combine any corresponding budget goals with actual changes - actualsplusgoals = [ - -- dbg0With (("actualsplusgoals: "<>)._brrShowDebug) $ - PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal - | PeriodicReportRow acct actualamts actualtot actualavg <- actualrows - - , let mbudgetgoals = HM.lookup (displayFull acct) budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage) - , let budgetmamts = maybe (Nothing <$ periods) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal] - , let mbudgettot = second3 <$> mbudgetgoals :: Maybe BudgetTotal - , let mbudgetavg = third3 <$> mbudgetgoals :: Maybe BudgetAverage - , let acctGoalByPeriod = 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 acctGoalByPeriod) | p <- periods ] :: [BudgetCell] - , let totamtandgoal = (Just actualtot, mbudgettot) - , let avgamtandgoal = (Just actualavg, mbudgetavg) - ] - where - budgetGoalsByAcct :: HashMap AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) = - HM.fromList [ (displayFull acct, (amts, tot, avg)) - | PeriodicReportRow acct amts tot avg <- - -- dbg0With (unlines.map (("budgetgoals: "<>).prrShowDebug)) $ - budgetrows - ] - - -- next, make rows for budget goals with no actual changes - othergoals = [ - -- dbg0With (("othergoals: "<>)._brrShowDebug) $ - PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal - | PeriodicReportRow acct budgetgoals budgettot budgetavg <- budgetrows - , displayFull acct `notElem` map prrFullName actualsplusgoals - , let acctGoalByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal - , let amtandgoals = [ (Just 0, Map.lookup p acctGoalByPeriod) | p <- periods ] :: [BudgetCell] - , let totamtandgoal = (Just 0, Just budgettot) - , let avgamtandgoal = (Just 0, Just budgetavg) - ] - - -- combine and re-sort rows - -- TODO: add --sort-budget to sort by budget goal amount - combinedrows :: [BudgetReportRow] = - -- map (dbg0With (("combinedrows: "<>)._brrShowDebug)) $ - sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows - where - (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows - mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst) - rows = actualsplusgoals ++ othergoals - - totalrow = PeriodicReportRow () - [ (Map.lookup p totActualByPeriod, Map.lookup p totGoalByPeriod) | p <- periods ] - ( Just actualgrandtot, budget budgetgrandtot ) - ( Just actualgrandavg, budget budgetgrandavg ) - where - totGoalByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal - totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change - budget b = if mixedAmountLooksZero b then Nothing else Just b -- tests diff --git a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs index 6011f9b75..3573a0375 100644 --- a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs +++ b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs @@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-| Multi-column balance reports, used by the balance command. @@ -19,15 +21,12 @@ module Hledger.Reports.MultiBalanceReport ( compoundBalanceReport, compoundBalanceReportWith, - sortRows, - sortRowsLike, - -- * Helper functions makeReportQuery, - getPostingsByColumn, getPostings, - startingPostings, - generateMultiBalanceReport, + generateMultiBalanceAccount, + generatePeriodicReport, + makePeriodicReportRow, -- -- * Tests tests_MultiBalanceReport @@ -35,21 +34,18 @@ module Hledger.Reports.MultiBalanceReport ( where import Control.Monad (guard) -import Data.Bifunctor (second) import Data.Foldable (toList) -import Data.List (sortOn, transpose) +import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty((:|))) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Data.Map (Map) -import qualified Data.Map as M +import qualified Data.HashSet as HS +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Ord (Down(..)) import Data.Semigroup (sconcat) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Time.Calendar (fromGregorian) -import Safe (lastDef, minimumMay) +import Data.These (these) +import Data.Time.Calendar (Day(..), addDays, fromGregorian) +import Data.Traversable (mapAccumL) import Hledger.Data import Hledger.Query @@ -86,9 +82,6 @@ dbg5 s = let p = "multiBalanceReport" in Hledger.Utils.dbg5 (p++" "++s) type MultiBalanceReport = PeriodicReport DisplayName MixedAmount type MultiBalanceReportRow = PeriodicReportRow DisplayName MixedAmount --- type alias just to remind us which AccountNames might be depth-clipped, below. -type ClippedAccountName = AccountName - -- | Generate a multicolumn balance report for the matched accounts, -- showing the change of balance, accumulated balance, or historical balance @@ -98,7 +91,7 @@ type ClippedAccountName = AccountName -- by the balance command (in multiperiod mode) and (via compoundBalanceReport) -- by the bs/cf/is commands. multiBalanceReport :: ReportSpec -> Journal -> MultiBalanceReport -multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) mempty +multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) where infer = infer_prices_ $ _rsReportOpts rspec -- | A helper for multiBalanceReport. This one takes some extra arguments, @@ -106,26 +99,23 @@ multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle -- 'AccountName's which should not be elided. Commands which run multiple -- reports (bs etc.) can generate the price oracle just once for efficiency, -- passing it to each report by calling this function directly. -multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> Set AccountName -> MultiBalanceReport -multiBalanceReportWith rspec' j priceoracle unelidableaccts = report +multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> MultiBalanceReport +multiBalanceReportWith rspec' j priceoracle = report where -- Queries, report/column dates. - (reportspan, colspans) = reportSpan j rspec' + (reportspan, colspans) = dbg5 "reportSpan" $ reportSpan j rspec' rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan -- force evaluation order to show price lookup after date spans in debug output (XXX not working) -- priceoracle = reportspan `seq` priceoracle0 - -- Group postings into their columns. - colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans + -- Get postings + ps = dbg5 "ps" $ getPostings rspec j priceoracle reportspan - -- The matched accounts with a starting balance. All of these should appear - -- in the report, even if they have no postings during the report period. - startbals = dbg5 "startbals" $ - startingBalances rspec j priceoracle $ startingPostings rspec j priceoracle reportspan + -- Process changes into normal, cumulative, or historical amounts, plus value them and mark which are uninteresting + acct = dbg5 "acct" $ generateMultiBalanceAccount rspec j priceoracle colspans ps -- Generate and postprocess the report, negating balances and taking percentages if needed - report = dbg4 "multiBalanceReportWith" $ - generateMultiBalanceReport rspec j priceoracle unelidableaccts colps startbals + report = dbg4 "multiBalanceReportWith" $ generateMultiBalanceReport (_rsReportOpts rspec) colspans acct -- | Generate a compound balance report from a list of CBCSubreportSpec. This -- shares postings between the subreports. @@ -141,23 +131,18 @@ compoundBalanceReportWith :: ReportSpec -> Journal -> PriceOracle compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr where -- Queries, report/column dates. - (reportspan, colspans) = reportSpan j rspec' + (reportspan, colspans) = dbg5 "reportSpan" $ reportSpan j rspec' rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan - -- Group postings into their columns. - colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans - - -- The matched postings with a starting balance. All of these should appear - -- in the report, even if they have no postings during the report period. - startps = dbg5 "startps" $ startingPostings rspec j priceoracle reportspan + -- Get postings + ps = dbg5 "ps" $ getPostings rspec j priceoracle reportspan subreports = map generateSubreport subreportspecs where generateSubreport CBCSubreportSpec{..} = ( cbcsubreporttitle -- Postprocess the report, negating balances and taking percentages if needed - , cbcsubreporttransform $ - generateMultiBalanceReport rspecsub j priceoracle mempty colps' startbals' + , cbcsubreporttransform $ generateMultiBalanceReport ropts colspans acct , cbcsubreportincreasestotal ) where @@ -165,10 +150,9 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr -- Add a restriction to this subreport to the report query. -- XXX in non-thorough way, consider updateReportSpec ? rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [cbcsubreportquery, _rsQuery rspec]} - -- Starting balances and column postings specific to this subreport. - startbals' = startingBalances rspecsub j priceoracle $ - filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) startps - colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery)) colps + -- Account representing this subreport + acct = generateMultiBalanceAccount rspecsub j priceoracle colspans $ + filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) ps -- Sum the subreport totals by column. Handle these cases: -- - no subreports @@ -181,47 +165,8 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr subreportTotal (_, sr, increasestotal) = (if increasestotal then id else fmap maNegate) $ prTotals sr - cbr = CompoundPeriodicReport "" (map fst colps) subreports overalltotals + cbr = CompoundPeriodicReport "" colspans subreports overalltotals --- XXX seems refactorable --- | Calculate accounts' balances on the report start date, from these postings --- which should be all postings before that date, and possibly also from account declarations. -startingBalances :: ReportSpec -> Journal -> PriceOracle -> [Posting] - -> HashMap AccountName Account -startingBalances rspec j priceoracle ps = - M.findWithDefault nullacct emptydatespan - <$> calculateReportMatrix rspec j priceoracle mempty [(emptydatespan, ps)] - --- | Postings needed to calculate starting balances. --- --- Balances at report start date, from all earlier postings which otherwise match the query. --- These balances are unvalued. --- TODO: Do we want to check whether to bother calculating these? isHistorical --- and startDate is not nothing, otherwise mempty? This currently gives a --- failure with some totals which are supposed to be 0 being blank. -startingPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting] -startingPostings rspec@ReportSpec{_rsQuery=query,_rsReportOpts=ropts} j priceoracle reportspan = - getPostings rspec' j priceoracle - where - rspec' = rspec{_rsQuery=startbalq,_rsReportOpts=ropts'} - -- If we're re-valuing every period, we need to have the unvalued start - -- balance, so we can do it ourselves later. - ropts' = case value_ ropts of - Just (AtEnd _) -> ropts{period_=precedingperiod, value_=Nothing} - _ -> ropts{period_=precedingperiod} - - -- q projected back before the report start date. - -- When there's no report start date, in case there are future txns (the hledger-ui case above), - -- we use emptydatespan to make sure they aren't counted as starting balance. - startbalq = dbg3 "startbalq" $ And [datelessq, precedingspanq] - datelessq = dbg3 "datelessq" $ filterQuery (not . queryIsDateOrDate2) query - - precedingperiod = dateSpanAsPeriod . spanIntersect precedingspan . - periodAsDateSpan $ period_ ropts - precedingspan = DateSpan Nothing (Exact <$> spanStart reportspan) - precedingspanq = (if date2_ ropts then Date2 else Date) $ case precedingspan of - DateSpan Nothing Nothing -> emptydatespan - a -> a -- | Remove any date queries and insert queries from the report span. -- The user's query expanded to the report span @@ -237,82 +182,97 @@ makeReportQuery rspec reportspan dateless = dbg3 "dateless" . filterQuery (not . queryIsDateOrDate2) dateqcons = if date2_ (_rsReportOpts rspec) then Date2 else Date --- | Group postings, grouped by their column -getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [(DateSpan, [Posting])] -getPostingsByColumn rspec j priceoracle colspans = - groupByDateSpan True getDate colspans ps - where - -- Postings matching the query within the report period. - ps = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle - -- The date spans to be included as report columns. - getDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) - -- | Gather postings matching the query within the report period. -getPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting] -getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle = - journalPostings $ journalValueAndFilterPostingsWith rspec' j priceoracle +getPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting] +getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle reportspan = + map clipPosting + . setPostingsCount + . journalPostings + $ journalValueAndFilterPostingsWith rspec' j priceoracle where - rspec' = rspec{_rsQuery=depthless, _rsReportOpts = ropts'} + -- Clip posting names to the requested depth + clipPosting p = p{paccount = clipOrEllipsifyAccountName depthSpec $ paccount p} + + -- If doing --count, set all posting amounts to "1". + setPostingsCount = case balancecalc_ ropts of + CalcPostingsCount -> map (postingTransformAmount (const $ mixed [num 1])) + _ -> id + + rspec' = rspec{_rsQuery=fullreportq,_rsReportOpts=ropts'} + -- If we're re-valuing every period, we need to have the unvalued start + -- balance, so we can do it ourselves later. ropts' = if isJust (valuationAfterSum ropts) - then ropts{value_=Nothing, conversionop_=Just NoConversionOp} -- If we're valuing after the sum, don't do it now - else ropts + then ropts{period_=dateSpanAsPeriod fullreportspan, value_=Nothing, conversionop_=Just NoConversionOp} -- If we're valuing after the sum, don't do it now + else ropts{period_=dateSpanAsPeriod fullreportspan} + + -- q projected back before the report start date. + -- When there's no report start date, in case there are future txns (the hledger-ui case above), + -- we use emptydatespan to make sure they aren't counted as starting balance. + fullreportq = dbg3 "fullreportq" $ And [datelessq, fullreportspanq] + datelessq = dbg3 "datelessq" $ filterQuery (not . queryIsDateOrDate2) depthlessq -- The user's query with no depth limit, and expanded to the report span -- if there is one (otherwise any date queries are left as-is, which -- handles the hledger-ui+future txns case above). - depthless = dbg3 "depthless" $ filterQuery (not . queryIsDepth) query + depthlessq = dbg3 "depthlessq" $ filterQuery (not . queryIsDepth) query --- | From set of postings, eg for a single report column, calculate the balance change in each account. --- Accounts and amounts will be depth-clipped appropriately if a depth limit is in effect. --- --- When --declared is used, accounts which have been declared with an account directive --- are also included, with a 0 balance change. But only leaf accounts, since non-leaf --- empty declared accounts are less useful in reports. This is primarily for hledger-ui. -acctChanges :: ReportSpec -> Journal -> [Posting] -> HashMap ClippedAccountName Account -acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_, declared_}} j ps = - HM.fromList [(aname a, a) | a <- accts] + depthSpec = dbg3 "depthSpec" . queryDepth $ filterQuery queryIsDepth query + + fullreportspan = if requiresHistorical ropts then DateSpan Nothing (Exact <$> spanEnd reportspan) else reportspan + fullreportspanq = (if date2_ ropts then Date2 else Date) $ case fullreportspan of + DateSpan Nothing Nothing -> emptydatespan + a -> a + +-- | Generate the 'Account' for the requested multi-balance report from a list +-- of 'Posting's. +generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [Posting] -> Account BalanceData +generateMultiBalanceAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans = + -- Add declared accounts if called with --declared and --empty + (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id) + -- Negate amounts if applicable + . (if invert_ ropts then fmap (mapBalanceData maNegate) else id) + -- Mark which accounts are boring and which are interesting + . markAccountBoring rspec + -- Set account declaration info (for sorting purposes) + . mapAccounts (accountSetDeclarationInfo j) + -- Process changes into normal, cumulative, or historical amounts, plus value them + . calculateReportAccount rspec j priceoracle colspans + +-- | Add declared accounts to the account tree. +addDeclaredAccounts :: Monoid a => ReportSpec -> Journal -> Account a -> Account a +addDeclaredAccounts rspec j acct = + these id id const <$> mergeAccounts acct declaredTree where - -- With --declared, add the query-matching declared accounts - -- (as dummy postings so they are processed like the rest). - -- This function is used for calculating both pre-start changes and column changes, - -- and the declared accounts are really only needed for the former, - -- but it's harmless to have them in the column changes as well. - ps' = ps ++ if declared_ then declaredacctps else [] - where - declaredacctps = - [nullposting{paccount=a} - | a <- journalLeafAccountNamesDeclared j - , matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq a - ] - where - accttypetagsq = dbg3 "accttypetagsq" $ - filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) query + declaredTree = + mapAccounts (\a -> a{aboring = not $ aname a `HS.member` HS.fromList declaredAccounts}) $ + accountTreeFromBalanceAndNames "root" (mempty <$ adata acct) declaredAccounts - filterbydepth = case accountlistmode_ of - ALTree -> filter (depthMatches . aname) -- a tree - just exclude deeper accounts - ALFlat -> clipAccountsAndAggregate depthSpec -- a list - aggregate deeper accounts at the depth limit - . filter ((0<) . anumpostings) -- and exclude empty parent accounts - where - depthSpec = dbg3 "depthq" . queryDepth $ filterQuery queryIsDepth query - depthMatches name = maybe True (accountNameLevel name <=) $ getAccountNameClippedDepth depthSpec name + -- With --declared, add the query-matching declared accounts (as dummy postings + -- so they are processed like the rest). + declaredAccounts = + map (clipOrEllipsifyAccountName depthSpec) . + filter (matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq) $ + journalAccountNamesDeclared j + + accttypetagsq = dbg3 "accttypetagsq" . + filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) $ + _rsQuery rspec + + depthSpec = queryDepth . filterQuery queryIsDepth $ _rsQuery rspec - accts = filterbydepth $ drop 1 $ accountsFromPostings ps' -- | Gather the account balance changes into a regular matrix, then -- accumulate and value amounts, as specified by the report options. -- Makes sure all report columns have an entry. -calculateReportMatrix :: ReportSpec -> Journal -> PriceOracle - -> HashMap ClippedAccountName Account - -> [(DateSpan, [Posting])] - -> HashMap ClippedAccountName (Map DateSpan Account) -calculateReportMatrix rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle startbals colps = -- PARTIAL: - -- Ensure all columns have entries, including those with starting balances - HM.mapWithKey rowbals allchanges +calculateReportAccount :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [Posting] -> Account BalanceData +calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans ps = -- PARTIAL: + mapPeriodData rowbals changesAcct where -- The valued row amounts to be displayed: per-period changes, -- zero-based cumulative totals, or -- starting-balance-based historical balances. - rowbals name unvaluedChanges = dbg5 "rowbals" $ case balanceaccum_ ropts of + rowbals :: PeriodData BalanceData -> PeriodData BalanceData + rowbals unvaluedChanges = case balanceaccum_ ropts of PerPeriod -> changes Cumulative -> cumulative Historical -> historical @@ -320,207 +280,208 @@ calculateReportMatrix rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle startb -- changes to report on: usually just the valued changes themselves, but use the -- differences in the valued historical amount for CalcValueChange and CalcGain. changes = case balancecalc_ ropts of - CalcChange -> M.mapWithKey avalue unvaluedChanges - CalcBudget -> M.mapWithKey avalue unvaluedChanges - CalcValueChange -> periodChanges valuedStart historical - CalcGain -> periodChanges valuedStart historical - CalcPostingsCount -> M.mapWithKey avalue unvaluedChanges + CalcChange -> avalue unvaluedChanges + CalcBudget -> avalue unvaluedChanges + CalcValueChange -> periodChanges historical + CalcGain -> periodChanges historical + CalcPostingsCount -> avalue unvaluedChanges -- the historical balance is the valued cumulative sum of all unvalued changes - historical = M.mapWithKey avalue $ cumulativeSum startingBalance unvaluedChanges + historical = avalue $ cumulativeSum unvaluedChanges -- since this is a cumulative sum of valued amounts, it should not be valued again - cumulative = cumulativeSum nullacct changes - startingBalance = HM.lookupDefault nullacct name startbals - valuedStart = avalue (DateSpan Nothing (Exact <$> historicalDate)) startingBalance + cumulative = cumulativeSum changes{pdpre = mempty} + avalue = periodDataValuation ropts j priceoracle colspans - -- In each column, get each account's balance changes - colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChanges rspec j) colps :: [(DateSpan, HashMap ClippedAccountName Account)] - -- Transpose it to get each account's balance changes across all columns - acctchanges = dbg5 "acctchanges" $ transposeMap colacctchanges :: HashMap AccountName (Map DateSpan Account) - -- Fill out the matrix with zeros in empty cells - allchanges = ((<>zeros) <$> acctchanges) <> (zeros <$ startbals) + changesAcct = dbg5With (\x -> "multiBalanceReport changesAcct\n" ++ showAccounts x) . + mapPeriodData (padPeriodData intervalStarts) $ + accountFromPostings getIntervalStartDate ps - avalue = acctApplyBoth . mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle - acctApplyBoth f a = a{aibalance = f $ aibalance a, aebalance = f $ aebalance a} - historicalDate = minimumMay $ mapMaybe spanStart colspans - zeros = M.fromList [(spn, nullacct) | spn <- colspans] - colspans = map fst colps + getIntervalStartDate p = intToDay <$> IS.lookupLE (dayToInt $ getPostingDate p) intervalStarts + getPostingDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) + intervalStarts = IS.fromList . map dayToInt $ case mapMaybe spanStart colspans of + [] -> [nulldate] -- Deal with the case of the empty journal + xs -> xs + dayToInt = fromInteger . toModifiedJulianDay + intToDay = ModifiedJulianDay . toInteger + +-- | The valuation function to use for the chosen report options. +periodDataValuation :: ReportOpts -> Journal -> PriceOracle -> [DateSpan] + -> PeriodData BalanceData -> PeriodData BalanceData +periodDataValuation ropts j priceoracle colspans = + opPeriodData valueBalanceData balanceDataPeriodEnds + where + valueBalanceData :: Day -> BalanceData -> BalanceData + valueBalanceData d = mapBalanceData (valueMixedAmount d) + + valueMixedAmount :: Day -> MixedAmount -> MixedAmount + valueMixedAmount = mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle + + balanceDataPeriodEnds :: PeriodData Day + balanceDataPeriodEnds = dbg5 "balanceDataPeriodEnds" $ case colspans of -- FIXME: Change colspans to nonempty list + [DateSpan Nothing Nothing] -> periodDataFromList nulldate [(nulldate, nulldate)] -- Empty journal + h:ds -> periodDataFromList (makeJustFst $ boundaries h) $ map (makeJust . boundaries) (h:ds) + [] -> error "balanceDataPeriodEnds: Shouldn't have empty colspans" -- PARTIAL: Shouldn't occur + where + boundaries spn = (spanStart spn, spanEnd spn) + + makeJust (Just x, Just y) = (x, addDays (-1) y) + makeJust _ = error "calculateReportAccount: expected all non-initial spans to have start and end dates" + makeJustFst (Just x, _) = addDays (-1) x + makeJustFst _ = error "calculateReportAccount: expected initial span to have an end date" + +-- | Mark which nodes of an 'Account' are boring, and so should be omitted from reports. +markAccountBoring :: ReportSpec -> Account BalanceData -> Account BalanceData +markAccountBoring ReportSpec{_rsQuery=query,_rsReportOpts=ropts} + -- If depth 0, all accounts except the top-level account are boring + | qdepthIsZero = markBoring False . mapAccounts (markBoring True) + -- Otherwise the top level account is boring, and subaccounts are boring if + -- they are both boring in and of themselves and are boring parents + | otherwise = markBoring True . mapAccounts (markBoringBy (liftA2 (&&) isBoring isBoringParent)) + where + -- Accounts boring on their own + isBoring :: Account BalanceData -> Bool + isBoring acct = tooDeep || allZeros + where + tooDeep = d > qdepth -- Throw out anything too deep + allZeros = isZeroRow balance amts && not keepEmptyAccount -- Throw away everything with a zero balance in the row, unless.. + keepEmptyAccount = empty_ ropts && keepWhenEmpty acct -- We are keeping empty rows and this row meets the criteria + + amts = pdperiods $ adata acct + d = accountNameLevel $ aname acct + + qdepth = fromMaybe maxBound . getAccountNameClippedDepth depthspec $ aname acct + balance = maybeStripPrices . case accountlistmode_ ropts of + ALTree | d == qdepth -> bdincludingsubs + _ -> bdexcludingsubs + + -- Accounts which don't have enough interesting subaccounts + isBoringParent :: Account a -> Bool + isBoringParent acct = case accountlistmode_ ropts of + ALTree -> notEnoughSubs || droppedAccount + ALFlat -> True + where + notEnoughSubs = length interestingSubs < minimumSubs + droppedAccount = accountNameLevel (aname acct) <= drop_ ropts + interestingSubs = filter (anyAccounts (not . aboring)) $ asubs acct + minimumSubs = if no_elide_ ropts then 1 else 2 + + isZeroRow balance = all (mixedAmountLooksZero . balance) + keepWhenEmpty = case accountlistmode_ ropts of + ALFlat -> any ((0<) . bdnumpostings) . pdperiods . adata -- Keep all accounts that have postings in flat mode + ALTree -> null . asubs -- Keep only empty leaves in tree mode + maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts + + qdepthIsZero = depthspec == DepthSpec (Just 0) [] + depthspec = queryDepth query + + markBoring v a = a{aboring = v} + markBoringBy f a = a{aboring = f a} + + +-- | Build a report row. +-- +-- Calculate the column totals. These are always the sum of column amounts. +generateMultiBalanceReport :: ReportOpts -> [DateSpan] -> Account BalanceData -> MultiBalanceReport +generateMultiBalanceReport ropts colspans = + reportPercent ropts . generatePeriodicReport makeMultiBalanceReportRow bdincludingsubs id ropts colspans -- | Lay out a set of postings grouped by date span into a regular matrix with rows -- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport -- from the columns. -generateMultiBalanceReport :: ReportSpec -> Journal -> PriceOracle -> Set AccountName - -> [(DateSpan, [Posting])] -> HashMap AccountName Account - -> MultiBalanceReport -generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle unelidableaccts colps0 startbals = - report +generatePeriodicReport :: Show c => + (forall a. ReportOpts -> (BalanceData -> MixedAmount) -> a -> Account b -> PeriodicReportRow a c) + -> (b -> MixedAmount) -> (c -> MixedAmount) + -> ReportOpts -> [DateSpan] -> Account b -> PeriodicReport DisplayName c +generatePeriodicReport makeRow treeAmt flatAmt ropts colspans acct = + PeriodicReport colspans (buildAndSort acct) totalsrow where - -- If doing --count, set all posting amounts to "1". - colps = - if balancecalc_ ropts == CalcPostingsCount - then map (second (map (postingTransformAmount (const $ mixed [num 1])))) colps0 - else colps0 + -- Build report rows and sort them + buildAndSort = dbg5 "sortedrows" . case accountlistmode_ ropts of + ALTree | sort_amount_ ropts -> buildRows . sortTreeByAmount + ALFlat | sort_amount_ ropts -> sortFlatByAmount . buildRows + _ -> buildRows . sortAccountTreeByDeclaration - -- Process changes into normal, cumulative, or historical amounts, plus value them - matrix = calculateReportMatrix rspec j priceoracle startbals colps + buildRows = buildReportRows makeRow ropts - -- All account names that will be displayed, possibly depth-clipped. - displaynames = dbg5 "displaynames" $ displayedAccounts rspec unelidableaccts matrix + -- Calculate column totals from the inclusive balances of the root account + totalsrow = dbg5 "totalsrow" $ makeRow ropts bdincludingsubs () acct - -- All the rows of the report. - rows = dbg5 "rows" . (if invert_ ropts then map (fmap maNegate) else id) -- Negate amounts if applicable - $ buildReportRows ropts displaynames matrix + sortTreeByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of + NormallyPositive -> sortAccountTreeOn (\r -> (Down $ amt r, aname r)) + NormallyNegative -> sortAccountTreeOn (\r -> (amt r, aname r)) + where + amt = mixedAmountStripCosts . sortKey . fmap treeAmt . pdperiods . adata + sortKey = case balanceaccum_ ropts of + PerPeriod -> maSum + _ -> maybe nullmixedamt snd . IM.lookupMax - -- Calculate column totals - totalsrow = dbg5 "totalsrow" $ calculateTotalsRow ropts rows $ length colps - - -- Sorted report rows. - sortedrows = dbg5 "sortedrows" $ sortRows ropts j rows - - -- Take percentages if needed - report = reportPercent ropts $ PeriodicReport (map fst colps) sortedrows totalsrow + sortFlatByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of + NormallyPositive -> sortOn (\r -> (Down $ amt r, prrFullName r)) + NormallyNegative -> sortOn (\r -> (amt r, prrFullName r)) + where amt = mixedAmountStripCosts . flatAmt . prrTotal -- | Build the report rows. -- One row per account, with account name info, row amounts, row total and row average. --- Rows are unsorted. -buildReportRows :: ReportOpts - -> HashMap AccountName DisplayName - -> HashMap AccountName (Map DateSpan Account) - -> [MultiBalanceReportRow] -buildReportRows ropts displaynames = - toList . HM.mapMaybeWithKey mkRow -- toList of HashMap's Foldable instance - does not sort consistently +-- Rows are sorted according to the order in the 'Account' tree. +buildReportRows :: forall b c. + (ReportOpts -> (BalanceData -> MixedAmount) -> DisplayName -> Account b -> PeriodicReportRow DisplayName c) + -> ReportOpts -> Account b -> [PeriodicReportRow DisplayName c] +buildReportRows makeRow ropts = mkRows True (-drop_ ropts) 0 where - mkRow name accts = do - displayname <- HM.lookup name displaynames - return $ PeriodicReportRow displayname rowbals rowtot rowavg + -- Build the row for an account at a given depth with some number of boring parents + mkRows :: Bool -> Int -> Int -> Account b -> [PeriodicReportRow DisplayName c] + mkRows isRoot d boringParents acct + -- Account is a boring root account, and should be bypassed entirely + | aboring acct && isRoot = buildSubrows d 0 + -- Account is boring and has been dropped, so should be skipped and move up the hierarchy + | aboring acct && d < 0 = buildSubrows (d + 1) 0 + -- Account is boring, and we can omit boring parents, so we should omit but keep track + | aboring acct && canOmitParents = buildSubrows d (boringParents + 1) + -- Account is not boring or otherwise should be displayed. + | otherwise = makeRow ropts balance displayname acct : buildSubrows (d + 1) 0 where - rowbals = map balance $ toList accts -- toList of Map's Foldable instance - does sort by key - -- The total and average for the row. - -- These are always simply the sum/average of the displayed row amounts. - -- Total for a cumulative/historical report is always the last column. - rowtot = case balanceaccum_ ropts of - PerPeriod -> maSum rowbals - _ -> lastDef nullmixedamt rowbals - rowavg = averageMixedAmounts rowbals - balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance + displayname = displayedName d boringParents $ aname acct + buildSubrows i b = concatMap (mkRows False i b) $ asubs acct --- | Calculate accounts which are to be displayed in the report, --- and their name and their indent level if displayed in tree mode. -displayedAccounts :: ReportSpec - -> Set AccountName - -> HashMap AccountName (Map DateSpan Account) - -> HashMap AccountName DisplayName -displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts - | qdepthIsZero = HM.singleton "..." $ DisplayName "..." "..." 0 - | otherwise = HM.mapWithKey (\a _ -> displayedName a) displayedAccts - where - displayedName name = case accountlistmode_ ropts of - ALTree -> DisplayName name leaf (max 0 $ level - 1 - boringParents) - ALFlat -> DisplayName name droppedName 0 + canOmitParents = flat_ ropts || not (no_elide_ ropts) + balance = case accountlistmode_ ropts of + ALTree -> bdincludingsubs + ALFlat -> bdexcludingsubs + + displayedName d boringParents name + | d == 0 && name == "root" = DisplayName "..." "..." 0 + | otherwise = case accountlistmode_ ropts of + ALTree -> DisplayName name leaf $ max 0 d + ALFlat -> DisplayName name droppedName 0 where - droppedName = accountNameDrop (drop_ ropts) name - leaf = accountNameFromComponents . reverse . map accountLeafName $ - droppedName : takeWhile notDisplayed parents - level = max 0 $ (accountNameLevel name) - drop_ ropts - parents = take (level - 1) $ parentAccountNames name - boringParents = if no_elide_ ropts then 0 else length $ filter notDisplayed parents - notDisplayed = not . (`HM.member` displayedAccts) + leaf = accountNameFromComponents + . reverse . take (boringParents + 1) . reverse + $ accountNameComponents droppedName + droppedName = accountNameDrop (drop_ ropts) name - -- Accounts which are to be displayed - displayedAccts = (if qdepthIsZero then id else HM.filterWithKey keep) valuedaccts - where - keep name amts = isInteresting name amts || name `HM.member` interestingParents - -- Accounts interesting for their own sake - isInteresting name amts = - d <= qdepth -- Throw out anything too deep - && ( name `Set.member` unelidableaccts -- Unelidable accounts should be kept unless too deep - ||(empty_ ropts && keepWhenEmpty amts) -- Keep empty accounts when called with --empty - || not (isZeroRow balance amts) -- Keep everything with a non-zero balance in the row - ) - where - d = accountNameLevel name - qdepth = fromMaybe maxBound $ getAccountNameClippedDepth depthspec name - keepWhenEmpty = case accountlistmode_ ropts of - ALFlat -> const True -- Keep all empty accounts in flat mode - ALTree -> all (null . asubs) -- Keep only empty leaves in tree mode - balance = maybeStripPrices . case accountlistmode_ ropts of - ALTree | d == qdepth -> aibalance - _ -> aebalance - where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts - - -- Accounts interesting because they are a fork for interesting subaccounts - interestingParents = dbg5 "interestingParents" $ case accountlistmode_ ropts of - ALTree -> HM.filterWithKey hasEnoughSubs numSubs - ALFlat -> mempty - where - hasEnoughSubs name nsubs = nsubs >= minSubs && accountNameLevel name > drop_ ropts - minSubs = if no_elide_ ropts then 1 else 2 - - isZeroRow balance = all (mixedAmountLooksZero . balance) - depthspec = queryDepth query - qdepthIsZero = depthspec == DepthSpec (Just 0) [] - numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts - --- | Sort the rows by amount or by account declaration order. -sortRows :: ReportOpts -> Journal -> [MultiBalanceReportRow] -> [MultiBalanceReportRow] -sortRows ropts j - | sort_amount_ ropts, ALTree <- accountlistmode_ ropts = sortTreeMBRByAmount - | sort_amount_ ropts, ALFlat <- accountlistmode_ ropts = sortFlatMBRByAmount - | otherwise = sortMBRByAccountDeclaration - where - -- Sort the report rows, representing a tree of accounts, by row total at each level. - -- Similar to sortMBRByAccountDeclaration/sortAccountNamesByDeclaration. - sortTreeMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow] - sortTreeMBRByAmount rows = mapMaybe (`HM.lookup` rowMap) sortedanames - where - accounttree = accountTree "root" $ map prrFullName rows - rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows - -- Set the inclusive balance of an account from the rows, or sum the - -- subaccounts if it's not present - accounttreewithbals = mapAccounts setibalance accounttree - setibalance a = a{aibalance = maybe (maSum . map aibalance $ asubs a) prrTotal $ - HM.lookup (aname a) rowMap} - sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals - sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree - - -- Sort the report rows, representing a flat account list, by row total (and then account name). - sortFlatMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow] - sortFlatMBRByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of - NormallyPositive -> sortOn (\r -> (Down $ amt r, prrFullName r)) - NormallyNegative -> sortOn (\r -> (amt r, prrFullName r)) - where amt = mixedAmountStripCosts . prrTotal - - -- Sort the report rows by account declaration order then account name. - sortMBRByAccountDeclaration :: [MultiBalanceReportRow] -> [MultiBalanceReportRow] - sortMBRByAccountDeclaration rows = sortRowsLike sortedanames rows - where - sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) $ map prrFullName rows - --- | Build the report totals row. +-- | Build a report row. -- -- Calculate the column totals. These are always the sum of column amounts. -calculateTotalsRow :: ReportOpts -> [MultiBalanceReportRow] -> Int -> PeriodicReportRow () MixedAmount -calculateTotalsRow ropts rows colcount = - PeriodicReportRow () coltotals grandtotal grandaverage +makeMultiBalanceReportRow :: ReportOpts -> (BalanceData -> MixedAmount) + -> a -> Account BalanceData -> PeriodicReportRow a MixedAmount +makeMultiBalanceReportRow = makePeriodicReportRow nullmixedamt sumAndAverageMixedAmounts + +-- | Build a report row. +-- +-- Calculate the column totals. These are always the sum of column amounts. +makePeriodicReportRow :: c -> (IM.IntMap c -> (c, c)) + -> ReportOpts -> (b -> c) + -> a -> Account b -> PeriodicReportRow a c +makePeriodicReportRow nullEntry totalAndAverage ropts balance name acct = + PeriodicReportRow name (toList rowbals) rowtotal avg where - isTopRow row = flat_ ropts || not (any (`HM.member` rowMap) parents) - where parents = init . expandAccountName $ prrFullName row - rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows - - colamts = transpose . map prrAmounts $ filter isTopRow rows - - coltotals :: [MixedAmount] = dbg5 "coltotals" $ case colamts of - [] -> replicate colcount nullmixedamt - _ -> map maSum colamts - - -- Calculate the grand total and average. These are always the sum/average - -- of the column totals. + rowbals = fmap balance . pdperiods $ adata acct + (total, avg) = totalAndAverage rowbals -- Total for a cumulative/historical report is always the last column. - grandtotal = case balanceaccum_ ropts of - PerPeriod -> maSum coltotals - _ -> lastDef nullmixedamt coltotals - grandaverage = averageMixedAmounts coltotals + rowtotal = case balanceaccum_ ropts of + PerPeriod -> total + _ -> maybe nullEntry snd $ IM.lookupMax rowbals -- | Map the report rows to percentages if needed reportPercent :: ReportOpts -> MultiBalanceReport -> MultiBalanceReport @@ -534,31 +495,6 @@ reportPercent ropts report@(PeriodicReport spans rows totalrow) (perdivide rowtotal $ prrTotal totalrow) (perdivide rowavg $ prrAverage totalrow) - --- | Transpose a Map of HashMaps to a HashMap of Maps. --- --- Makes sure that all DateSpans are present in all rows. -transposeMap :: [(DateSpan, HashMap AccountName a)] - -> HashMap AccountName (Map DateSpan a) -transposeMap = foldr (uncurry addSpan) mempty - where - addSpan spn acctmap seen = HM.foldrWithKey (addAcctSpan spn) seen acctmap - - addAcctSpan spn acct a = HM.alter f acct - where f = Just . M.insert spn a . fromMaybe mempty - --- | A sorting helper: sort a list of things (eg report rows) keyed by account name --- to match the provided ordering of those same account names. -sortRowsLike :: [AccountName] -> [PeriodicReportRow DisplayName b] -> [PeriodicReportRow DisplayName b] -sortRowsLike sortedas rows = mapMaybe (`HM.lookup` rowMap) sortedas - where rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows - --- | Given a list of account names, find all forking parent accounts, i.e. --- those which fork between different branches -subaccountTallies :: [AccountName] -> HashMap AccountName Int -subaccountTallies = foldr incrementParent mempty . expandAccountNames - where incrementParent a = HM.insertWith (+) (parentAccountName a) 1 - -- | A helper: what percentage is the second mixed amount of the first ? -- Keeps the sign of the first amount. -- Uses unifyMixedAmount to unify each argument and then divides them. @@ -572,26 +508,13 @@ perdivide a b = fromMaybe (error' errmsg) $ do -- PARTIAL: return $ mixed [per $ if aquantity b' == 0 then 0 else aquantity a' / abs (aquantity b') * 100] where errmsg = "Cannot calculate percentages if accounts have different commodities (Hint: Try --cost, -V or similar flags.)" --- Add the values of two accounts. Should be right-biased, since it's used --- in scanl, so other properties (such as anumpostings) stay in the right place -sumAcct :: Account -> Account -> Account -sumAcct Account{aibalance=i1,aebalance=e1} a@Account{aibalance=i2,aebalance=e2} = - a{aibalance = i1 `maPlus` i2, aebalance = e1 `maPlus` e2} - --- Subtract the values in one account from another. Should be left-biased. -subtractAcct :: Account -> Account -> Account -subtractAcct a@Account{aibalance=i1,aebalance=e1} Account{aibalance=i2,aebalance=e2} = - a{aibalance = i1 `maMinus` i2, aebalance = e1 `maMinus` e2} - --- | Extract period changes from a cumulative list -periodChanges :: Account -> Map k Account -> Map k Account -periodChanges start amtmap = - M.fromDistinctAscList . zip dates $ zipWith subtractAcct amts (start:amts) - where (dates, amts) = unzip $ M.toAscList amtmap - -- | Calculate a cumulative sum from a list of period changes. -cumulativeSum :: Account -> Map DateSpan Account -> Map DateSpan Account -cumulativeSum start = snd . M.mapAccum (\a b -> let s = sumAcct a b in (s, s)) start +cumulativeSum :: Traversable t => t BalanceData -> t BalanceData +cumulativeSum = snd . mapAccumL (\prev new -> let z = prev <> new in (z, z)) mempty + +-- | Extract period changes from a cumulative list. +periodChanges :: Traversable t => t BalanceData -> t BalanceData +periodChanges = snd . mapAccumL (\prev new -> (new, opBalanceData maMinus new prev)) mempty -- tests diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index 747c0c84b..c0d6ae411 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -243,10 +243,10 @@ summarisePostingsInDateSpan spn@(DateSpan b e) wd mdepth showempty ps summarypes = map (, dateSpanAsPeriod spn) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps anames = nubSort $ map paccount ps -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping - accts = accountsFromPostings ps + accts = accountsFromPostings (const Nothing) ps balance a = maybe nullmixedamt bal $ lookupAccount a accts where - bal = if isclipped a then aibalance else aebalance + bal = (if isclipped a then bdincludingsubs else bdexcludingsubs) . pdpre . adata isclipped a' = maybe False (accountNameLevel a' >=) mdepth diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index c7aa937d8..01fb0d3b2 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -52,6 +52,7 @@ module Hledger.Reports.ReportOptions ( journalApplyValuationFromOptsWith, mixedAmountApplyValuationAfterSumFromOptsWith, valuationAfterSum, + requiresHistorical, intervalFromRawOpts, queryFromFlags, transactionDateFn, @@ -677,21 +678,20 @@ journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceo -- | Select the Account valuation functions required for performing valuation after summing -- amounts. Used in MultiBalanceReport to value historical and similar reports. mixedAmountApplyValuationAfterSumFromOptsWith :: ReportOpts -> Journal -> PriceOracle - -> (DateSpan -> MixedAmount -> MixedAmount) + -> (Day -> MixedAmount -> MixedAmount) mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle = case valuationAfterSum ropts of Just mc -> case balancecalc_ ropts of CalcGain -> gain mc - _ -> \spn -> valuation mc spn . costing + _ -> \d -> valuation mc d . costing Nothing -> const id where - valuation mc spn = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) - gain mc spn = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) + valuation mc d = mixedAmountValueAtDate priceoracle styles mc d + gain mc d = mixedAmountGainAtDate priceoracle styles mc d costing = case fromMaybe NoConversionOp $ conversionop_ ropts of NoConversionOp -> id ToCost -> styleAmounts styles . mixedAmountCost styles = journalCommodityStyles j - err = error' "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" -- | If the ReportOpts specify that we are performing valuation after summing amounts, -- return Just of the commodity symbol we're converting to, Just Nothing for the default, @@ -699,12 +699,15 @@ mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle = -- Used for example with historical reports with --value=end. valuationAfterSum :: ReportOpts -> Maybe (Maybe CommoditySymbol) valuationAfterSum ropts = case value_ ropts of - Just (AtEnd mc) | valueAfterSum -> Just mc - _ -> Nothing - where valueAfterSum = balancecalc_ ropts == CalcValueChange - || balancecalc_ ropts == CalcGain - || balanceaccum_ ropts /= PerPeriod + Just (AtEnd mc) | requiresHistorical ropts -> Just mc + _ -> Nothing +-- | If the ReportOpts specify that we will need to consider historical +-- postings, either because this is a historical report, or because the +-- valuation strategy requires historical amounts. +requiresHistorical :: ReportOpts -> Bool +requiresHistorical ReportOpts{balanceaccum_ = accum, balancecalc_ = calc} = + accum == Historical || calc == CalcValueChange || calc == CalcGain -- | Convert report options to a query, ignoring any non-flag command line arguments. queryFromFlags :: ReportOpts -> Query @@ -780,7 +783,7 @@ reportSpanBothDates = reportSpanHelper True -- primary and secondary dates. reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, [DateSpan]) reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts} = - (reportspan, intervalspans) + (reportspan, if not (null intervalspans) then intervalspans else [reportspan]) where -- The date span specified by -b/-e/-p options and query args if any. requestedspan = dbg3 "requestedspan" $ if bothdates then queryDateSpan' query else queryDateSpan (date2_ ropts) query diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index cbd51b8fd..c3bf27760 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -115,6 +115,8 @@ library Text.Tabular.AsciiWide Text.WideString other-modules: + Hledger.Data.BalanceData + Hledger.Data.PeriodData Paths_hledger_lib autogen-modules: Paths_hledger_lib @@ -163,6 +165,7 @@ library , template-haskell , terminal-size >=0.3.3 , text >=1.2.4.1 + , these >=1.0.0 , time >=1.5 , timeit , transformers >=0.2 @@ -222,6 +225,7 @@ test-suite doctest , template-haskell , terminal-size >=0.3.3 , text >=1.2.4.1 + , these >=1.0.0 , time >=1.5 , timeit , transformers >=0.2 @@ -283,6 +287,7 @@ test-suite unittest , template-haskell , terminal-size >=0.3.3 , text >=1.2.4.1 + , these >=1.0.0 , time >=1.5 , timeit , transformers >=0.2 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 640926ff2..e58cd9041 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -85,6 +85,7 @@ dependencies: - template-haskell - terminal-size >=0.3.3 - text >=1.2.4.1 +- these >=1.0.0 - time >=1.5 - timeit - transformers >=0.2 diff --git a/hledger-web/Hledger/Web/Widget/Common.hs b/hledger-web/Hledger/Web/Widget/Common.hs index d54aa1ef3..354b51e99 100644 --- a/hledger-web/Hledger/Web/Widget/Common.hs +++ b/hledger-web/Hledger/Web/Widget/Common.hs @@ -82,9 +82,9 @@ balanceReportAsHtml (journalR, registerR) here hideEmpty j qparam qopts (items, where l = ledgerFromJournal Any j indent a = preEscapedString $ concat $ replicate (2 + 2 * a) " " - hasSubAccounts acct = maybe True (not . null . asubs) (ledgerAccount l acct) + hasSubAccounts acct = maybe True (not . null . asubs) $ ledgerAccount l acct isInterestingAccount acct = maybe False isInteresting $ ledgerAccount l acct - where isInteresting a = not (mixedAmountLooksZero (aebalance a)) || any isInteresting (asubs a) + where isInteresting a = not (all (mixedAmountLooksZero . bdexcludingsubs) . pdperiods $ adata a) || any isInteresting (asubs a) matchesAcctSelector acct = Just True == ((`matchesAccount` acct) <$> inAccountQuery qopts) accountQuery :: AccountName -> Text diff --git a/hledger/test/balance/balance.test b/hledger/test/balance/balance.test index 4f3eb9835..aa0356dbc 100644 --- a/hledger/test/balance/balance.test +++ b/hledger/test/balance/balance.test @@ -161,7 +161,6 @@ $ hledger -f - balance -N --output-format=csv # ** 10. --declared includes all declared leaf accounts, even if they have no postings. # They are filtered, depth-clipped, and form trees like the others. -# (XXX Here a:ac is not declared and so not shown, even though normally a balance report clipped to depth 2 would show it. Wrong ?) < account a account a:aa @@ -172,27 +171,17 @@ $ hledger -f - balance -NE --declared --tree --depth 2 a 0 a 0 aa 0 ab + 0 ac -# ** 11. In list mode we can see that non-leaf declared accounts are excluded. -< -account a -account a:aa -account a:ab -account a:ac:aca -account b +# ** 11. In list mode we can see that declared accounts are included, even if they have no postings. $ hledger -f - balance -NE --declared --flat + 0 a 0 a:aa 0 a:ab 0 a:ac:aca 0 b # ** 12. not:ACCT queries work with declared accounts. -< -account a -account a:aa -account a:ab -account a:ac:aca -account b $ hledger -f - balance -NE --declared not:a 0 b @@ -217,3 +206,20 @@ $ hledger -f- bal --count -1 1 b -------------------- 3 + +# ** 16. Make sure that balance --flat --empty does not display implied +# accounts (i.e. those with no postings, like "assets", here), but does show +# accounts that have postings with zero balance (like "assets:bank:checking" +# here). +$ hledger -f sample.journal balance --flat --empty + 0 assets:bank:checking + $1 assets:bank:saving + $-2 assets:cash + $1 expenses:food + $1 expenses:supplies + $-1 income:gifts + $-1 income:salary + $1 liabilities:debts +-------------------- + 0 + diff --git a/hledger/test/balance/budget.test b/hledger/test/balance/budget.test index 21711cdd4..7df90ce03 100644 --- a/hledger/test/balance/budget.test +++ b/hledger/test/balance/budget.test @@ -50,7 +50,6 @@ Budget performance in 2016-12-01..2016-12-03: || 2016-12-01 2016-12-02 2016-12-03 ==================++============================================================== assets:cash || $-10 [ 40% of $-25] $-14 [56% of $-25] $-51 [204% of $-25] - expenses || $10 [ 40% of $25] $14 [56% of $25] $51 [204% of $25] expenses:cab || 0 0 $15 expenses:food || $10 [100% of $10] $9 [90% of $10] $11 [110% of $10] expenses:leisure || 0 [ 0% of $15] $5 [33% of $15] 0 [ 0% of $15] @@ -340,7 +339,6 @@ Budget performance in 2018-05-01..2018-06-30, valued at period ends: || 2018-05-31 2018-06-30 ================++================================= || €-10 €-10 - assets || €10 €10 [ 0] assets:bank || 0 €-1 [ 100% of €-1] assets:pension || €10 €11 [1100% of €1] ----------------++--------------------------------- @@ -747,8 +745,7 @@ Budget performance in 2023-08: ==============++================= income || 0 [0% of $-200] employment || 0 [0% of $-100] - gifts || 0 - cash || 0 [0% of $-100] + gifts:cash || 0 [0% of $-100] --------------++----------------- || 0 [0% of $-200] diff --git a/hledger/test/incomestatement.test b/hledger/test/incomestatement.test index 6c3ddf668..63a02fc57 100644 --- a/hledger/test/incomestatement.test +++ b/hledger/test/incomestatement.test @@ -282,7 +282,7 @@ Quarterly Income Statement 2008 expenses:food || 0 50.0 % 0 0 50.0 % 50.0 % expenses:supplies || 0 50.0 % 0 0 50.0 % 50.0 % -# ** 9. With --declared, declared leaf accounts are included, and in the right place. +# ** 9. With --declared, declared accounts are included, and in the right place. < account revenues account revenues:aa @@ -296,6 +296,7 @@ Income Statement .. =================++==== Revenues || -----------------++---- + revenues || 0 revenues:aa || 0 revenues:ab || 0 revenues:ac:aca || 0