ref: lib: Use sparse accounts to increase efficiency and flexibility.

Author: Xitian9

Diff for: hledger-lib/Hledger/Data/Account.hs

@@ -107,20 +107,20 @@ accountFromBalances name bal = Account
 -- 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 -> Day) -> [Day] -> [Posting] -> [Account AccountBalance]
-accountsFromPostings getPostingDate days = flattenAccounts . accountFromPostings getPostingDate days
+accountsFromPostings :: (Posting -> Maybe Day) -> [Posting] -> [Account AccountBalance]
+accountsFromPostings getPostingDate = flattenAccounts . accountFromPostings getPostingDate
 
 -- | Derive 1. an account tree and 2. each account's total exclusive
 -- and inclusive changes from a list of postings.
 -- This is the core of the balance command (and of *ledger).
 -- The accounts are returned as tree.
-accountFromPostings :: (Posting -> Day) -> [Day] -> [Posting] -> Account AccountBalance
-accountFromPostings getPostingDate days ps =
+accountFromPostings :: (Posting -> Maybe Day) -> [Posting] -> Account AccountBalance
+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{abalances = HM.lookupDefault emptyMap name accountMap}
+    setBalance a = a{abalances = HM.lookupDefault mempty name accountMap}
       where name = if aname a == "root" then "..." else aname a
     accountMap   = processPostings ps
 
@@ -130,9 +130,7 @@ accountFromPostings getPostingDate days ps =
         processAccountName p = HM.alter (updateAccountBalance p) (paccount p)
         updateAccountBalance p = Just
                                . insertAccountBalances (getPostingDate p) (AccountBalance 1 (pamount p) nullmixedamt)
-                               . fromMaybe emptyMap
-
-    emptyMap = emptyAccountBalances days
+                               . fromMaybe mempty
 
 -- | Convert a list of account names to a tree of Account objects,
 -- with just the account names filled in.
@@ -208,12 +206,12 @@ sumAccounts a = a{asubs = subs, abalances = setImplicitBalances $ abalances a}
     subtotals = foldMap abalances subs
 
     setImplicitBalances :: AccountBalances AccountBalance -> AccountBalances AccountBalance
-    setImplicitBalances = if null subs
-      then fmap setibal
-      else opAccountBalances addibal subtotals
+    setImplicitBalances = mergeAccountBalances combineChildren (fmap onlyChildren) (fmap noChildren) subtotals
+
+    combineChildren children this = this  {abibalance = abebalance this <> abibalance children}
+    onlyChildren    children      = mempty{abibalance = abibalance children}
+    noChildren               this = this  {abibalance = abebalance this}
 
-    setibal bal@(AccountBalance _ ebal _) = bal{abibalance = ebal}
-    addibal (AccountBalance _ _ ibal) bal@(AccountBalance _ ebal _) = bal{abibalance = ebal <> ibal}
 
 -- | Remove all subaccounts below a certain depth.
 clipAccounts :: Int -> Account a -> Account a
@@ -288,12 +286,6 @@ filterAccounts p a
 -- | Merge two accounts and their subaccounts.
 --
 -- This assumes that the top-level 'Account's have the same name.
---
--- Unless the 'Account's and all their subaccounts have the same collection of
--- 'Day' keys, it will probably produce unhelpful output: do not do this unless
--- you really know what you're doing. Merging two accounts with unequal
--- 'Day' keys can be useful when they have the same Intervals but not
--- necessarily equal spans, as in the budget reports.
 mergeAccounts :: Account a -> Account b -> Account (These a b)
 mergeAccounts a = tieAccountParents . merge a
   where
@@ -384,9 +376,9 @@ showAccountDebug a = printf "%-25s %s %4s"
 tests_Account = testGroup "Account" [
     testGroup "accountFromPostings" [
       testCase "no postings, no days" $
-        accountFromPostings undefined [] [] @?= accountTree "root" []
+        accountFromPostings undefined [] @?= accountTree "root" []
      ,testCase "no postings, only 2000-01-01" $
          allAccounts (all (\d -> (ModifiedJulianDay $ toInteger d) == fromGregorian 2000 01 01) . IM.keys . abdatemap . abalances)
-                     (accountFromPostings undefined [fromGregorian 2000 01 01] []) @? "Not all abalances have exactly 2000-01-01"
+                     (accountFromPostings undefined []) @? "Not all abalances have exactly 2000-01-01"
     ]
   ]

Diff for: hledger-lib/Hledger/Data/AccountBalance.hs

@@ -14,6 +14,7 @@ module Hledger.Data.AccountBalance
 , insertAccountBalances
 , opAccountBalances
 , mergeAccountBalances
+, padAccountBalances
 
 , applyAccountBalance
 , opAccountBalance
@@ -25,6 +26,7 @@ module Hledger.Data.AccountBalance
 
 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
@@ -82,10 +84,10 @@ lookupAccountBalance d (AccountBalances h as) =
     maybe h snd $ IM.lookupLE (fromInteger $ toModifiedJulianDay d) as
 
 -- | Add the 'AccountBalance' to the appropriate location in 'AccountBalances'.
-insertAccountBalances :: Semigroup a => Day -> a -> AccountBalances a -> AccountBalances a
-insertAccountBalances day b balances = case IM.lookupLE (fromInteger $ toModifiedJulianDay day) (abdatemap balances) of
-    Nothing     -> balances{abhistorical = b <> abhistorical balances}
-    Just (d, a) -> balances{abdatemap = IM.insert d (b <> a) $ abdatemap balances}
+insertAccountBalances :: Semigroup a => Maybe Day -> a -> AccountBalances a -> AccountBalances a
+insertAccountBalances mday b balances = case mday of
+    Nothing  -> balances{abhistorical = abhistorical balances <> b}
+    Just day -> balances{abdatemap = IM.insertWith (<>) (fromInteger $ toModifiedJulianDay day) b $ abdatemap balances}
 
 -- | Performs an operation on the contents of two 'AccountBalances'.
 --
@@ -102,6 +104,10 @@ mergeAccountBalances f only1 only2 = \(AccountBalances h1 as1) (AccountBalances
   where
     merge = IM.mergeWithKey (\_ x1 x2 -> Just $ f x1 x2) only1 only2
 
+-- | Pad out the datemap of an 'AccountBalances' so that every key from a set is present.
+padAccountBalances :: Monoid a => IS.IntSet -> AccountBalances a -> AccountBalances a
+padAccountBalances keys bal = bal{abdatemap = abdatemap bal <> IM.fromSet (const mempty) keys}
+
 
 instance Show AccountBalance where
   showsPrec d (AccountBalance n e i) =

Diff for: hledger-lib/Hledger/Data/Ledger.hs

@@ -63,7 +63,7 @@ ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as}
     j'  = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude
           filterJournalPostings q' j
     -- Ledger does not use date-separated balances, so dates are left empty
-    as  = accountsFromPostings (const nulldate) [] $ journalPostings j'
+    as  = accountsFromPostings (const $ Just nulldate) $ journalPostings j'
     j'' = filterJournalPostings depthq j'
 
 -- | List a ledger's account names.

Diff for: hledger-lib/Hledger/Reports/MultiBalanceReport.hs

@@ -39,11 +39,12 @@ import Data.List (sortOn)
 import Data.List.NonEmpty (NonEmpty((:|)))
 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.These (these)
-import Data.Time.Calendar (Day, addDays, fromGregorian)
+import Data.Time.Calendar (Day(..), addDays, fromGregorian)
 import Data.Traversable (mapAccumL)
 
 import Hledger.Data
@@ -291,13 +292,18 @@ calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colsp
         cumulative = cumulativeSum changes{abhistorical = mempty}
         avalue = accountBalancesValuation ropts j priceoracle colspans
 
-    changesAcct = dbg5With (\x -> "multiBalanceReport changesAcct\n" ++ showAccounts x) $
-        accountFromPostings getDate intervalStarts ps
+    changesAcct = dbg5With (\x -> "multiBalanceReport changesAcct\n" ++ showAccounts x) .
+        mapAccounts (\a -> a{abalances = padAccountBalances intervalStarts $ abalances a}) $
+        accountFromPostings getIntervalStartDate ps
 
-    getDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec))
-    intervalStarts = case mapMaybe spanStart colspans of
+    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.
 accountBalancesValuation :: ReportOpts -> Journal -> PriceOracle -> [DateSpan]

Diff for: hledger-lib/Hledger/Reports/PostingsReport.hs

@@ -243,7 +243,7 @@ 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 postingDate [] ps
+    accts = accountsFromPostings (const Nothing) ps
     balance a = maybe nullmixedamt bal $ lookupAccount a accts
       where
         bal = (if isclipped a then abibalance else abebalance) . abhistorical . abalances