better register summarising with --depth and -E support, datespan splitting bugfix

Ledger/Dates.hs

@@ -69,10 +69,13 @@ splitSpan Yearly s     = splitspan start next s where (start,next) = (startofyea
 splitspan _ _ (DateSpan Nothing Nothing) = []
 splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)]
 splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)]
-splitspan startof next (DateSpan (Just b) (Just e))
+splitspan startof next s@(DateSpan (Just b) (Just e))
-    | b >= e = []
+    | b == e = [s]
-    | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] 
+    | otherwise = splitspan' startof next s
-                  ++ splitspan startof next (DateSpan (Just $ next $ startof b) (Just e))
+    where splitspan' startof next (DateSpan (Just b) (Just e))
+              | b >= e = []
+              | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] 
+                            ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e))
     
 -- | Parse a period expression to an Interval and overall DateSpan using
 -- the provided reference date.
@@ -393,3 +396,7 @@ justdatespan rdate = do
   optional (string "in" >> many spacenonewline)
   d <- smartdate
   return $ spanFromSmartDate rdate d
+
+nulldatespan = DateSpan Nothing Nothing
+
+mkdatespan b e = DateSpan (Just $ parsedate b) (Just $ parsedate e)

Ledger/Ledger.hs

@@ -30,23 +30,27 @@ instance Show Ledger where
 
 -- | Convert a raw ledger to a more efficient cached type, described above.  
 cacheLedger :: [String] -> RawLedger -> Ledger
-cacheLedger apats l = Ledger l ant amap
+cacheLedger apats l = Ledger l ant acctmap
     where
+      ts = filtertxns apats $ rawLedgerTransactions l
       ant = rawLedgerAccountNameTree l
       anames = flatten ant
-      ts = filtertxns apats $ rawLedgerTransactions l
+      txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- anames])
+      subacctsof a = filter (a `isAccountNamePrefixOf`) anames
+      subtxnsof a = concat [txnmap ! a | a <- [a] ++ subacctsof a]
+      balmap = Map.union 
+               (Map.fromList [(a,sumTransactions $ subtxnsof a) | a <- anames]) 
+               (Map.fromList [(a,Mixed []) | a <- anames])
+      acctmap = Map.fromList [(a, mkacct a) | a <- anames]
+      mkacct a = Account a (txnmap ! a) (balmap ! a)
+
+-- | Convert a list of transactions to a map from account name to the list
+-- of all transactions in that account.
+transactionsByAccount :: [Transaction] -> Map.Map AccountName [Transaction]
+transactionsByAccount ts = Map.fromList [(account $ head g, g) | g <- groupedts]
+    where
       sortedts = sortBy (comparing account) ts
       groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts
-      txnmap = Map.union 
-               (Map.fromList [(account $ head g, g) | g <- groupedts])
-               (Map.fromList [(a,[]) | a <- anames])
-      txnsof = (txnmap !)
-      subacctsof a = filter (a `isAccountNamePrefixOf`) anames
-      subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]
-      balmap = Map.union 
-               (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- anames])
-               (Map.fromList [(a,Mixed []) | a <- anames])
-      amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames]
 
 filtertxns :: [String] -> [Transaction] -> [Transaction]
 filtertxns apats ts = filter (matchpats apats . account) ts
@@ -92,6 +96,6 @@ ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l
 -- or DateSpan Nothing Nothing if there are no transactions.
 ledgerDateSpan l
     | null ts = DateSpan Nothing Nothing
-    | otherwise = DateSpan (Just $ date $ head ts) (Just $ date $ last ts)
+    | otherwise = DateSpan (Just $ date $ head ts) (Just $ addDays 1 $ date $ last ts)
     where
       ts = sortBy (comparing date) $ ledgerTransactions l

NOTES

@@ -14,7 +14,6 @@ clever tricks like the plague." --Edsger Dijkstra
 *** should accept - before currency symbol ?
 *** can't parse comment line immediately after or within an entry
 ** features
-*** show empty reporting intervals with the -E option, for clarity/consistency/graphing
 *** actual/effective entry & txn dates, for completeness
 *** speed
 **** easy profiling

RegisterCommand.hs

@@ -40,15 +40,66 @@ showRegisterReport opts args l
       matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t
       dopt = displayFromOpts opts
       empty = Empty `elem` opts
-      summaryts = concat $ map (\(n,s) -> summarise n s (filter (isTransactionInDateSpan s) ts)) $ zip [1..] spans
+      depth = depthFromOpts opts
+      summaryts = concatMap summarisespan (zip spans [1..])
+      summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)
+      transactionsinspan s = filter (isTransactionInDateSpan s) ts
       spans = splitSpan interval (ledgerDateSpan l)
-      -- generate a grouped set of summary transactions for this date span
+                        
-      summarise :: Int -> DateSpan -> [Transaction] -> [Transaction]
+-- | Convert a date span (representing a reporting interval) and a list of
-      summarise _ _ [] = []
+-- transactions within it to a new list of transactions aggregated by
-      summarise n (DateSpan b e) ts = summarytxns (b',e') n empty ts
+-- account, which showtxns will render as a summary for this interval.
-          where
+-- 
-            b' = fromMaybe (date $ head ts) b
+-- As usual with date spans the end date is exclusive, but for display
-            e' = fromMaybe (date $ last ts) e
+-- purposes we show the previous day as end date, like ledger.
+-- 
+-- A unique entryno value is provided to that the new transactions will be
+-- grouped as one entry.
+-- 
+-- When a depth argument is present, transactions to accounts of greater
+-- depth are aggregated where possible.
+-- 
+-- The showempty flag forces the display of a zero-transaction span
+-- and also zero-transaction accounts within the span.
+summariseTransactionsInDateSpan :: DateSpan -> Int -> Maybe Int -> Bool -> [Transaction] -> [Transaction]
+summariseTransactionsInDateSpan (DateSpan b e) entryno depth showempty ts
+    | null ts && showempty = [txn]
+    | null ts = []
+    | otherwise = summaryts'
+    where
+      txn = nulltxn{entryno=entryno, date=b', description="- "++(showDate $ addDays (-1) e')}
+      b' = fromMaybe (date $ head ts) b
+      e' = fromMaybe (date $ last ts) e
+      summaryts'
+          | showempty = summaryts
+          | otherwise = filter (not . isZeroMixedAmount . amount) summaryts
+      -- aggregate balances by account, like cacheLedger:
+      anames = sort $ nub $ map account ts
+      allnames = expandAccountNames anames
+      -- from cacheLedger:
+      txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allnames])
+      txnsof = (txnmap !)  -- a's txns
+      subacctsof a = filter (a `isAccountNamePrefixOf`) anames -- a plus any subaccounts
+      subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a] -- a's and subaccounts' txns
+      inclusivebalmap = Map.union  -- subaccount-including balances for all accounts
+               (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- allnames])
+               (Map.fromList [(a,Mixed []) | a <- anames])
+      --
+      -- then do depth-clipping
+      exclusivebalmap = Map.union  -- subaccount-excluding balances for all accounts
+               (Map.fromList [(a,(sumTransactions $ txnsof a)) | a <- allnames])
+               (Map.fromList [(a,Mixed []) | a <- anames])
+      inclusivebalanceof = (inclusivebalmap !)
+      exclusivebalanceof = (exclusivebalmap !)
+      clippedanames = clipAccountNames depth anames
+      isclipped a = accountNameLevel a >= fromMaybe 9999 depth
+      balancetoshowfor a = (if isclipped a then inclusivebalanceof else exclusivebalanceof) a
+      summaryts = [txn{account=a,amount=balancetoshowfor a} | a <- clippedanames]
+
+clipAccountNames :: Maybe Int -> [AccountName] -> [AccountName]
+clipAccountNames Nothing as = as
+clipAccountNames (Just d) as = nub $ map (clip d) as 
+    where clip d = accountNameFromComponents . take d . accountNameComponents
 
 -- | Does the given transaction fall within the given date span ?
 isTransactionInDateSpan :: DateSpan -> Transaction -> Bool
@@ -57,39 +108,6 @@ isTransactionInDateSpan (DateSpan Nothing (Just e))  (Transaction{date=d}) = d<e
 isTransactionInDateSpan (DateSpan (Just b) Nothing)  (Transaction{date=d}) = d>=b
 isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{date=d}) = d>=b && d<e
 
--- | Convert a date span and a list of transactions within that date span
--- to a new list of transactions aggregated by account, which when
--- rendered by showtxns will display a summary for the date span.  Both
--- ends of the date span must be specified so we pass a tuple of dates.
--- As usual with date spans the second date is exclusive, but when
--- rendering we will show the previous (inclusive) date.  
--- A unique entryno value is provided so that these dummy transactions
--- will be rendered as one entry. Also the showempty flag is provided to
--- control display of zero-balance accounts.
-summarytxns :: (Day,Day) -> Int -> Bool -> [Transaction] -> [Transaction]
-summarytxns (b,e) entryno showempty ts = summaryts'
-    where
-      summaryts'
-          | showempty = summaryts
-          | otherwise = filter (not . isZeroMixedAmount . amount) summaryts
-      summaryts = [templtxn{account=a,amount=balmap ! a} | a <- anames]
-      templtxn = nulltxn{entryno=entryno,date=b,description="- "++(showDate eprev)}
-      eprev = addDays (-1) e
-      anames = sort $ nub $ map account ts
-      -- from cacheLedger:
-      sortedts = sortBy (comparing account) ts
-      groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts
-      txnmap = Map.union 
-               (Map.fromList [(account $ head g, g) | g <- groupedts])
-               (Map.fromList [(a,[]) | a <- anames])
-      txnsof = (txnmap !)
-      subacctsof a = filter (a `isAccountNamePrefixOf`) anames
-      subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]
-      balmap = Map.union 
-               (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- anames])
-               (Map.fromList [(a,Mixed []) | a <- anames])
-      --
-
 -- | Show transactions one per line, with each date/description appearing
 -- only once, and a running balance.
 showtxns [] _ _ = ""

Tests.hs

@@ -156,6 +156,67 @@ misc_tests = TestList [
     "every day from aug to oct" `gives` "(Daily,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
     "daily from aug"            `gives` "(Daily,DateSpan (Just 2008-08-01) Nothing)"
     "every week to 2009"        `gives` "(Weekly,DateSpan Nothing (Just 2009-01-01))"
+  ,                  
+  "splitSpan"     ~: do
+    let (interval,span) `gives` spans = assertequal spans (splitSpan interval span)
+    (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`
+     [mkdatespan "2008/01/01" "2009/01/01"]
+    (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`
+     [mkdatespan "2008/01/01" "2008/04/01"
+     ,mkdatespan "2008/04/01" "2008/07/01"
+     ,mkdatespan "2008/07/01" "2008/10/01"
+     ,mkdatespan "2008/10/01" "2009/01/01"
+     ]
+    (Quarterly,nulldatespan) `gives`
+     [nulldatespan]
+    (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives`
+     [mkdatespan "2008/01/01" "2008/01/01"]
+    (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives`
+     [mkdatespan "2008/01/01" "2008/01/01"]
+  ,                  
+  "summariseTransactionsInDateSpan"     ~: do
+    let (b,e,entryno,depth,showempty,ts) `gives` summaryts = assertequal (summaryts) (summariseTransactionsInDateSpan (mkdatespan b e) entryno depth showempty ts)
+
+    ("2008/01/01","2009/01/01",0,Nothing,False,[]) `gives` 
+     []
+
+    ("2008/01/01","2009/01/01",0,Nothing,True,[]) `gives` 
+     [
+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31"}
+     ]
+
+    ("2008/01/01","2009/01/01",0,Nothing,False,[
+      nulltxn{description="desc",account="expenses:food:groceries",amount=Mixed [dollars 1]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 2]}
+     ,nulltxn{description="desc",account="expenses:food",          amount=Mixed [dollars 4]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 8]}
+     ]) `gives` 
+     [
+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food",          amount=Mixed [dollars 4]}
+     ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:dining",   amount=Mixed [dollars 10]}
+     ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:groceries",amount=Mixed [dollars 1]}
+     ]
+
+    ("2008/01/01","2009/01/01",0,Just 2,False,[
+      nulltxn{description="desc",account="expenses:food:groceries",amount=Mixed [dollars 1]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 2]}
+     ,nulltxn{description="desc",account="expenses:food",          amount=Mixed [dollars 4]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 8]}
+     ]) `gives` 
+     [
+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food",          amount=Mixed [dollars 15]}
+     ]
+
+    ("2008/01/01","2009/01/01",0,Just 1,False,[
+      nulltxn{description="desc",account="expenses:food:groceries",amount=Mixed [dollars 1]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 2]}
+     ,nulltxn{description="desc",account="expenses:food",          amount=Mixed [dollars 4]}
+     ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 8]}
+     ]) `gives` 
+     [
+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses",          amount=Mixed [dollars 15]}
+     ]
+
   ]
 
 balancereportacctnames_tests = TestList