support reporting intervals in period expressions and register report, and -W/-M/-D

Ledger/Dates.hs

@@ -8,8 +8,11 @@ We represent these as a triple of strings like ("2008","12",""),
 ("","","tomorrow"), ("","last","week").
 
 A 'DateSpan' is the span of time between two specific calendar dates, or
-possibly an open-ended span where one or both dates are missing. We use
+an open-ended span where one or both dates are unspecified. (A date span
-this term since "period" and "interval" are ambiguous.
+with both ends unspecified matches all dates.)
+
+An 'Interval' is ledger's "reporting interval" - weekly, monthly,
+quarterly, etc.
 
 -}
 
@@ -53,10 +56,32 @@ elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2
 dayToUTC :: Day -> UTCTime
 dayToUTC d = localTimeToUTC utc (LocalTime d midnight)
 
--- | Convert a period expression to a date span using the provided reference date.
+-- | Split a DateSpan into one or more consecutive spans at the specified interval.
-spanFromPeriodExpr refdate = fromparse . parsewith (periodexpr refdate) 
+splitSpan :: Interval -> DateSpan -> [DateSpan]
+splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]
+splitSpan NoInterval s = [s]
+splitSpan Daily s      = splitspan start next s where (start,next) = (startofday,nextday)
+splitSpan Weekly s     = splitspan start next s where (start,next) = (startofweek,nextweek)
+splitSpan Monthly s    = splitspan start next s where (start,next) = (startofmonth,nextmonth)
+splitSpan Quarterly s  = splitspan start next s where (start,next) = (startofquarter,nextquarter)
+splitSpan Yearly s     = splitspan start next s where (start,next) = (startofyear,nextyear)
 
--- | Convert a smart date string to a date span using the provided reference date.
+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))
+    | 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.
+parsePeriodExpr :: Day -> String -> (Interval, DateSpan)
+parsePeriodExpr refdate expr = (interval,span)
+    where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr
+    
+-- | Convert a single smart date string to a date span using the provided
+-- reference date.
 spanFromSmartDateString :: Day -> String -> DateSpan
 spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate
     where
@@ -135,6 +160,7 @@ fixSmartDate refdate sdate = fix sdate
 prevday :: Day -> Day
 prevday = addDays (-1)
 nextday = addDays 1
+startofday = id
 
 thisweek = startofweek
 prevweek = startofweek . addDays (-7)
@@ -292,21 +318,78 @@ lastthisnextthing = do
       ]
   return ("",r,p)
 
-periodexpr :: Day -> Parser DateSpan
+periodexpr :: Day -> Parser (Interval, DateSpan)
-periodexpr rdate = try (doubledateperiod rdate) <|> (singledateperiod rdate)
+periodexpr rdate = choice $ map try [
+                    intervalanddateperiodexpr rdate,
+                    intervalperiodexpr,
+                    dateperiodexpr rdate,
+                    (return $ (NoInterval,DateSpan Nothing Nothing))
+                   ]
 
-doubledateperiod :: Day -> Parser DateSpan
+intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan)
-doubledateperiod rdate = do
+intervalanddateperiodexpr rdate = do
-  string "from"
   many spacenonewline
+  i <- periodexprinterval
+  many spacenonewline
+  s <- periodexprdatespan rdate
+  return (i,s)
+
+intervalperiodexpr :: Parser (Interval, DateSpan)
+intervalperiodexpr = do
+  many spacenonewline
+  i <- periodexprinterval
+  return (i, DateSpan Nothing Nothing)
+
+dateperiodexpr :: Day -> Parser (Interval, DateSpan)
+dateperiodexpr rdate = do
+  many spacenonewline
+  s <- periodexprdatespan rdate
+  return (NoInterval, s)
+
+periodexprinterval :: Parser Interval
+periodexprinterval = 
+    choice $ map try [
+                tryinterval "day" "daily" Daily,
+                tryinterval "week" "weekly" Weekly,
+                tryinterval "month" "monthly" Monthly,
+                tryinterval "quarter" "quarterly" Quarterly,
+                tryinterval "year" "yearly" Yearly
+               ]
+    where
+      tryinterval s1 s2 v = 
+          choice [try (string $ "every "++s1), try (string s2)] >> return v
+
+periodexprdatespan :: Day -> Parser DateSpan
+periodexprdatespan rdate = choice $ map try [
+                            doubledatespan rdate,
+                            fromdatespan rdate,
+                            todatespan rdate,
+                            justdatespan rdate
+                           ]
+
+doubledatespan :: Day -> Parser DateSpan
+doubledatespan rdate = do
+  optional (string "from" >> many spacenonewline)
   b <- smartdate
   many spacenonewline
-  string "to"
+  optional (string "to" >> many spacenonewline)
-  many spacenonewline
   e <- smartdate
-  let span = DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
+  return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
-  return span
 
-singledateperiod :: Day -> Parser DateSpan
+fromdatespan :: Day -> Parser DateSpan
-singledateperiod rdate = smartdate >>= return . spanFromSmartDate rdate
+fromdatespan rdate = do
+  string "from" >> many spacenonewline
+  b <- smartdate
+  return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
 
+todatespan :: Day -> Parser DateSpan
+todatespan rdate = do
+  string "to" >> many spacenonewline
+  e <- smartdate
+  return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
+
+justdatespan :: Day -> Parser DateSpan
+justdatespan rdate = do
+  optional (string "in" >> many spacenonewline)
+  d <- smartdate
+  return $ spanFromSmartDate rdate d

Ledger/Ledger.hs

@@ -87,3 +87,11 @@ ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accoun
 -- | Get a ledger's tree of accounts rooted at the specified account.
 ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account)
 ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l
+
+-- | The (explicit) date span containing all the ledger's transactions,
+-- 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)
+    where
+      ts = sortBy (comparing date) $ ledgerTransactions l

Ledger/Types.hs

@@ -16,6 +16,9 @@ type SmartDate = (String,String,String)
 
 data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)
 
+data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly 
+                deriving (Eq,Show,Ord)
+
 type AccountName = String
 
 data Side = L | R deriving (Eq,Show,Ord) 

NOTES

@@ -11,30 +11,7 @@ clever tricks like the plague." --Edsger Dijkstra
 * to do
 ** errors
 ** features
-*** period expressions, for ease of use
+*** show empty reporting intervals with the -E option, for clarity/consistency/graphing
-**** from and/or to
-**** reporting intervals
-***** design types
-***** parse intervals
-     every day
-     every week
-     every monthly
-     every quarter
-     every year
-     every N days     # N is any integer
-     every N weeks
-     every N months
-     every N quarters
-     every N years
-     daily
-     weekly
-     biweekly
-     monthly
-     bimonthly
-     quarterly
-     yearly
-***** implement in register report
-***** -W/-M/-Y
 *** actual/effective entry & txn dates, for completeness
 *** speed
 **** easy profiling
@@ -43,6 +20,15 @@ clever tricks like the plague." --Edsger Dijkstra
 *** ~/.hledgerrc, for setting defaults
 *** more ledger features from README (?)
 *** new features
+**** support complete period syntax ?
+    every N days     # N is any integer
+    every N weeks
+    every N months
+    every N quarters
+    every N years
+    biweekly
+    bimonthly
+**** -Q quarterly interval option, for consistency/convenience ?
 **** easy timelog queries when called as hours
 **** curses gui
 **** web gui

Options.hs

@@ -50,6 +50,9 @@ options = [
  Option []    ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns",
  Option ['n'] ["collapse"]     (NoArg  Collapse)      "balance report: no grand total",
  Option ['s'] ["subtotal"]     (NoArg  SubTotal)      "balance report: show subaccounts",
+ Option ['W'] ["weekly"]       (NoArg  WeeklyOpt)        "register report: show weekly summary",
+ Option ['M'] ["monthly"]      (NoArg  MonthlyOpt)       "register report: show monthly summary",
+ Option ['Y'] ["yearly"]       (NoArg  YearlyOpt)        "register report: show yearly summary",
  Option ['h'] ["help"] (NoArg  Help)                  "show this help",
  Option ['v'] ["verbose"]      (NoArg  Verbose)       "verbose test output",
  Option ['V'] ["version"]      (NoArg  Version)       "show version"
@@ -73,15 +76,24 @@ data Opt =
     OptionsAnywhere | 
     Collapse |
     SubTotal |
+    WeeklyOpt |
+    MonthlyOpt |
+    YearlyOpt |
     Help |
     Verbose |
     Version
     deriving (Show,Eq)
 
 -- yow..
+optsWithConstructor f opts = concatMap get opts
+    where get o = if f v == o then [o] else [] where v = value o
+
 optValuesForConstructor f opts = concatMap get opts
     where get o = if f v == o then [v] else [] where v = value o
 
+optValuesForConstructors fs opts = concatMap get opts
+    where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o
+
 -- | Parse the command-line arguments into ledger options, ledger command
 -- name, and ledger command arguments. Also any dates in the options are
 -- converted to full YYYY/MM/DD format, while we are in the IO monad
@@ -109,22 +121,37 @@ fixOptDates opts = do
         where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]"
     fixopt _ o            = o
 
--- | Figure out the date span we should report on, based on any
+-- | Figure out the overall date span we should report on, based on any
--- begin/end/period options provided. This could be really smart but I'm
+-- begin/end/period options provided. If there is a period option, the
--- just going to look for 1. the first Period or 2. the first Begin and
+-- others are ignored.
--- first End.
 dateSpanFromOpts :: Day -> [Opt] -> DateSpan
 dateSpanFromOpts refdate opts
-    | not $ null ps = spanFromPeriodExpr refdate $ head ps
+    | not $ null popts = snd $ parsePeriodExpr refdate $ head popts
     | otherwise = DateSpan firstb firste
     where
-      ps = optValuesForConstructor Period opts
+      popts = optValuesForConstructor Period opts
-      firstb = listtomaybeday $ optValuesForConstructor Begin opts
+      bopts = optValuesForConstructor Begin opts
-      firste = listtomaybeday $ optValuesForConstructor End opts
+      eopts = optValuesForConstructor End opts
-      listtomaybeday [] = Nothing
+      firstb = listtomaybeday bopts
-      listtomaybeday vs = Just $ parse $ head vs
+      firste = listtomaybeday eopts
-      parse s = parsedate $ printf "%04s/%02s/%02s" y m d
+      listtomaybeday vs = if null vs then Nothing else Just $ parse $ head vs
-          where (y,m,d) = fromparse $ parsewith smartdate $ s
+          where parse = parsedate . fixSmartDateStr refdate
+
+-- | Figure out the reporting interval, if any, specified by the options.
+-- If there is a period option, the others are ignored.
+intervalFromOpts :: [Opt] -> Interval
+intervalFromOpts opts
+    | not $ null popts = fst $ parsePeriodExpr refdate $ head popts
+    | otherwise = case otheropts of
+                    []             -> NoInterval
+                    (WeeklyOpt:_)  -> Weekly
+                    (MonthlyOpt:_) -> Monthly
+                    (YearlyOpt:_)  -> Yearly
+    where
+      popts = optValuesForConstructor Period opts
+      otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,YearlyOpt]) opts 
+      -- doesn't affect the interval, but parsePeriodExpr needs something
+      refdate = parsedate "0001/01/01"
 
 -- | Get the value of the (first) depth option, if any.
 depthFromOpts :: [Opt] -> Maybe Int

README

@@ -158,8 +158,12 @@ Other differences
 * hledger keeps differently-priced amounts of the same commodity separate, at the moment
 * hledger refers to the entry and transaction "description", ledger calls it "note"
 * hledger doesn't require a space after flags like -f
-* hledger always shows timelog balances in hours
 * hledger doesn't parse all ledger file constructs (and may choke ? please report)
-* hledger doesn't count an unfinished timelog session
 * hledger interprets "last/this/next week" as weeks beginning on monday
 * hledger provides "--cost" as a synonym for "--basis"
+* hledger's "weekly" reporting intervals always start on mondays
+* hledger shows start and end dates of full intervals, not just the span containing data
+* hledger period expressions don't support "biweekly", "bimonthly", or "every N days/weeks/..." 
+* hledger always shows timelog balances in hours
+* hledger doesn't count an unfinished timelog session
+* (disabled for now: hledger counts timelog sessions on the day they end, ledger on the day they start)

RegisterCommand.hs

@@ -6,6 +6,8 @@ A ledger-compatible @register@ command.
 
 module RegisterCommand
 where
+import qualified Data.Map as Map
+import Data.Map ((!))
 import Ledger
 import Options
 
@@ -26,27 +28,80 @@ DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA
 @
 -}
 showRegisterReport :: [Opt] -> [String] -> Ledger -> String
-showRegisterReport opts args l = showtxns ts nulltxn nullmixedamt
+showRegisterReport opts args l
+    | interval == NoInterval = showtxns ts nulltxn nullmixedamt
+    | otherwise = showtxns summaryts nulltxn nullmixedamt
     where
-      ts = filter matchapats $ ledgerTransactions l
+      interval = intervalFromOpts opts
+      ts = filter (not . isZeroMixedAmount . amount) $ filter (matchdisplayopt dopt) $ filter matchapats $ ledgerTransactions l
       matchapats t = matchpats apats $ account t
       apats = fst $ parseAccountDescriptionArgs opts args
       matchdisplayopt Nothing t = True
       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
+      spans = splitSpan interval (ledgerDateSpan l)
+      -- generate a grouped set of summary transactions for this date span
+      summarise :: Int -> DateSpan -> [Transaction] -> [Transaction]
+      summarise _ _ [] = []
+      summarise n (DateSpan b e) ts = summarytxns (b',e') n empty ts
+          where
+            b' = fromMaybe (date $ head ts) b
+            e' = fromMaybe (date $ last ts) e
 
-      -- show display-filtered transactions, one per line, with a running balance
+-- | Does the given transaction fall within the given date span ?
-      showtxns [] _ _ = ""
+isTransactionInDateSpan :: DateSpan -> Transaction -> Bool
-      showtxns (t@Transaction{amount=a}:ts) tprev bal =
+isTransactionInDateSpan (DateSpan Nothing Nothing)   _ = True
-          (if (isZeroMixedAmount a || (not $ matchdisplayopt dopt t)) then "" else this) ++ showtxns ts t bal'
+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 [] _ _ = ""
+showtxns (t@Transaction{amount=a}:ts) tprev bal = this ++ showtxns ts t bal'
     where
       this = showtxn (t `issame` tprev) t bal'
       issame t1 t2 = entryno t1 == entryno t2
       bal' = bal + amount t
 
-      -- show one transaction line, with or without the entry details
+-- | Show one transaction line and balance with or without the entry details.
-      showtxn :: Bool -> Transaction -> MixedAmount -> String
+showtxn :: Bool -> Transaction -> MixedAmount -> String
-      showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n"
+showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n"
     where
       entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc
       date = showDate $ da

Tests.hs

@@ -129,6 +129,33 @@ misc_tests = TestList [
     "this year"    `gives` "2008/01/01"
     "last year"    `gives` "2007/01/01"
     "next year"    `gives` "2009/01/01"
+  ,
+  "dateSpanFromOpts"     ~: do
+    let todaysdate = parsedate "2008/11/26"
+    let opts `gives` spans = assertequal spans (show $ dateSpanFromOpts todaysdate opts)
+    [] `gives` "DateSpan Nothing Nothing"
+    [Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
+    [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
+    [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
+  ,
+  "intervalFromOpts"     ~: do
+    let opts `gives` interval = assertequal interval (intervalFromOpts opts)
+    [] `gives` NoInterval
+    [WeeklyOpt] `gives` Weekly
+    [MonthlyOpt] `gives` Monthly
+    [YearlyOpt] `gives` Yearly
+    [Period "weekly"] `gives` Weekly
+    [Period "monthly"] `gives` Monthly
+    [WeeklyOpt, Period "yearly"] `gives` Yearly
+  ,                  
+  "period expressions"     ~: do
+    let todaysdate = parsedate "2008/11/26"
+    let str `gives` result = assertequal ("Right "++result) (show $ parsewith (periodexpr todaysdate) str)
+    "from aug to oct"           `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
+    "aug to oct"                `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
+    "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))"
   ]
 
 balancereportacctnames_tests = TestList 
@@ -356,8 +383,24 @@ registercommand_tests = TestList [
   do 
     ""     `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
     "2008" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
--- need to get datespan into ledgerFromString, or preconvert period expressions
+    "2007" `periodexprgives` []
---    "2007" `periodexprgives` []
+    "june" `periodexprgives` ["2008/06/01","2008/06/02","2008/06/03"]
+
+    let l = ledgerfromstring [] sample_ledger_str
+    assertequal (
+     "2008/01/01 - 2008/12/31         assets:cash                     $-2          $-2\n" ++
+     "                                assets:saving                    $1          $-1\n" ++
+     "                                expenses:food                    $1            0\n" ++
+     "                                expenses:supplies                $1           $1\n" ++
+     "                                income:gifts                    $-1            0\n" ++
+     "                                income:salary                   $-1          $-1\n" ++
+     "                                liabilities:debts                $1            0\n" ++
+     "")
+     (showRegisterReport [Period "yearly"] [] l)
+
+    assertequal ["2008/01/01","2008/04/01","2008/10/01"] (datesfromregister $ showRegisterReport [Period "quarterly"] [] l)
+--    assertequal ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] (datesfromregister $ showRegisterReport [Period "quarterly"] [] l)
+
  ]
   where
     expr `displayexprgives` dates = 
@@ -369,9 +412,9 @@ registercommand_tests = TestList [
         assertequal dates (datesfromregister r)
         where
           r = showRegisterReport [Period expr] [] l
-          l = ledgerfromstring [] sample_ledger_str
+          l = ledgerfromstringwithopts [Period expr] [] refdate sample_ledger_str
-          
+          refdate = parsedate "2008/11/26"
-datesfromregister = filter (not . null) .  map (strip . take 10) . lines
+    datesfromregister = filter (not . null) .  map (strip . take 10) . lines
 
   
 ------------------------------------------------------------------------------