1 {-| 
    2 
    3 A ledger-compatible @register@ command.
    4 
    5 -}
    6 
    7 module Commands.Register
    8 where
    9 import Prelude hiding (putStr)
   10 import qualified Data.Map as Map
   11 import Data.Map ((!))
   12 import Ledger
   13 import Options
   14 import System.IO.UTF8
   15 
   16 
   17 -- | Print a register report.
   18 register :: [Opt] -> [String] -> Ledger -> IO ()
   19 register opts args l = putStr $ showRegisterReport opts args l
   20 
   21 {- |
   22 Generate the register report. Each ledger entry is displayed as two or
   23 more lines like this:
   24 
   25 @
   26 date (10)  description (20)     account (22)            amount (11)  balance (12)
   27 DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA
   28                                 aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA
   29                                 ...                     ...         ...
   30 @
   31 -}
   32 showRegisterReport :: [Opt] -> [String] -> Ledger -> String
   33 showRegisterReport opts args l
   34     | interval == NoInterval = showtxns displayedts nulltxn startbal
   35     | otherwise = showtxns summaryts nulltxn startbal
   36     where
   37       interval = intervalFromOpts opts
   38       ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l
   39       filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth)
   40                   | otherwise = id
   41       filterempties
   42           | Empty `elem` opts = id
   43           | otherwise = filter (not . isZeroMixedAmount . tamount)
   44       (precedingts, ts') = break (matchdisplayopt dopt) ts
   45       (displayedts, _) = span (matchdisplayopt dopt) ts'
   46       startbal = sumTransactions precedingts
   47       matchapats t = matchpats apats $ taccount t
   48       (apats,_) = parsePatternArgs args
   49       matchdisplayopt Nothing t = True
   50       matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t
   51       dopt = displayFromOpts opts
   52       empty = Empty `elem` opts
   53       depth = depthFromOpts opts
   54       summaryts = concatMap summarisespan (zip spans [1..])
   55       summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)
   56       transactionsinspan s = filter (isTransactionInDateSpan s) displayedts
   57       spans = splitSpan interval (ledgerDateSpan l)
   58                         
   59 -- | Convert a date span (representing a reporting interval) and a list of
   60 -- transactions within it to a new list of transactions aggregated by
   61 -- account, which showtxns will render as a summary for this interval.
   62 -- 
   63 -- As usual with date spans the end date is exclusive, but for display
   64 -- purposes we show the previous day as end date, like ledger.
   65 -- 
   66 -- A unique tnum value is provided so that the new transactions will be
   67 -- grouped as one entry.
   68 -- 
   69 -- When a depth argument is present, transactions to accounts of greater
   70 -- depth are aggregated where possible.
   71 -- 
   72 -- The showempty flag forces the display of a zero-transaction span
   73 -- and also zero-transaction accounts within the span.
   74 summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction]
   75 summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts
   76     | null ts && showempty = [txn]
   77     | null ts = []
   78     | otherwise = summaryts'
   79     where
   80       txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')}
   81       b' = fromMaybe (tdate $ head ts) b
   82       e' = fromMaybe (tdate $ last ts) e
   83       summaryts'
   84           | showempty = summaryts
   85           | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts
   86       txnanames = sort $ nub $ map taccount ts
   87       -- aggregate balances by account, like cacheLedger, then do depth-clipping
   88       (_,_,exclbalof,inclbalof) = groupTransactions ts
   89       clippedanames = clipAccountNames depth txnanames
   90       isclipped a = accountNameLevel a >= depth
   91       balancetoshowfor a =
   92           (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)
   93       summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames]
   94 
   95 clipAccountNames :: Int -> [AccountName] -> [AccountName]
   96 clipAccountNames d as = nub $ map (clip d) as 
   97     where clip d = accountNameFromComponents . take d . accountNameComponents
   98 
   99 -- | Show transactions one per line, with each date/description appearing
  100 -- only once, and a running balance.
  101 showtxns [] _ _ = ""
  102 showtxns (t@Transaction{tamount=a}:ts) tprev bal = this ++ showtxns ts t bal'
  103     where
  104       this = showtxn (t `issame` tprev) t bal'
  105       issame t1 t2 = tnum t1 == tnum t2
  106       bal' = bal + tamount t
  107 
  108 -- | Show one transaction line and balance with or without the entry details.
  109 showtxn :: Bool -> Transaction -> MixedAmount -> String
  110 showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n"
  111     where
  112       entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc
  113       date = showDate $ da
  114       desc = printf "%-20s" $ elideRight 20 de :: String
  115       p = showPosting $ Posting s a amt "" tt
  116       bal = padleft 12 (showMixedAmountOrZero b)
  117       Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t
  118