support basic --period expressions, containing a single smart date

Ledger/Dates.hs

@@ -53,7 +53,41 @@ elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2
 dayToUTC :: Day -> UTCTime
 dayToUTC d = localTimeToUTC utc (LocalTime d midnight)
 
--- | Convert a fuzzy date string to an explicit yyyy/mm/dd string using
+-- | Convert a smart date string to a date span using the provided date as
+-- reference point.
+spanFromSmartDateString :: Day -> String -> DateSpan
+spanFromSmartDateString refdate s = DateSpan (Just b) (Just e)
+    where
+      sdate = fromparse $ parsewith smartdate s
+      (ry,rm,rd) = toGregorian refdate
+      (b,e) = span sdate
+      span :: SmartDate -> (Day,Day)
+      span ("","","today")       = (refdate, nextday refdate)
+      span ("","this","day")     = (refdate, nextday refdate)
+      span ("","","yesterday")   = (prevday refdate, refdate)
+      span ("","last","day")     = (prevday refdate, refdate)
+      span ("","","tomorrow")    = (nextday refdate, addDays 2 refdate)
+      span ("","next","day")     = (nextday refdate, addDays 2 refdate)
+      span ("","last","week")    = (prevweek refdate, thisweek refdate)
+      span ("","this","week")    = (thisweek refdate, nextweek refdate)
+      span ("","next","week")    = (nextweek refdate, startofweek $ addDays 14 refdate)
+      span ("","last","month")   = (prevmonth refdate, thismonth refdate)
+      span ("","this","month")   = (thismonth refdate, nextmonth refdate)
+      span ("","next","month")   = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)
+      span ("","last","quarter") = (prevquarter refdate, thisquarter refdate)
+      span ("","this","quarter") = (thisquarter refdate, nextquarter refdate)
+      span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)
+      span ("","last","year")    = (prevyear refdate, thisyear refdate)
+      span ("","this","year")    = (thisyear refdate, nextyear refdate)
+      span ("","next","year")    = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
+      span ("","",d)             = (day, nextday day) where day = fromGregorian ry rm (read d)
+      span ("",m,"")             = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1
+      span ("",m,d)              = (day, nextday day) where day = fromGregorian ry (read m) (read d)
+      span (y,"","")             = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1
+      span (y,m,"")              = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1
+      span (y,m,d)               = (day, nextday day) where day = fromGregorian (read y) (read m) (read d)
+
+-- | Convert a smart date string to an explicit yyyy/mm/dd string using
 -- the provided date as reference point.
 fixSmartDateStr :: Day -> String -> String
 fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d
@@ -86,7 +120,10 @@ fixSmartDate refdate sdate = fix sdate
       fix ("","this","year")    = thisyear refdate
       fix ("","next","year")    = nextyear refdate
       fix ("","",d)             = fromGregorian ry rm (read d)
+      fix ("",m,"")             = fromGregorian ry (read m) 1
       fix ("",m,d)              = fromGregorian ry (read m) (read d)
+      fix (y,"","")             = fromGregorian (read y) 1 1
+      fix (y,m,"")              = fromGregorian (read y) (read m) 1
       fix (y,m,d)               = fromGregorian (read y) (read m) (read d)
       (ry,rm,rd) = toGregorian refdate
 
@@ -184,13 +221,13 @@ ym = do
   datesepchar
   m <- many1 digit
   guard (read m <= 12)
-  return (y,m,"1")
+  return (y,m,"")
 
 y :: Parser SmartDate
 y = do
   y <- many1 digit
   guard (read y >= 1000)
-  return (y,"1","1")
+  return (y,"","")
 
 d :: Parser SmartDate
 d = do
@@ -210,19 +247,22 @@ md = do
 months = ["january","february","march","april","may","june",
           "july","august","september","october","november","december"]
 
-mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
+mons   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
+
+monthIndex s = maybe 0 (+1) $ (map toLower s) `elemIndex` months
+monIndex s   = maybe 0 (+1) $ (map toLower s) `elemIndex` mons
 
 month :: Parser SmartDate
 month = do
-  m <- choice $ map string months
+  m <- choice $ map (try . string) months
-  let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months
+  let i = monthIndex m
-  return ("",show i,"1")
+  return $ ("",show i,"")
 
 mon :: Parser SmartDate
 mon = do
-  m <- choice $ map string mons
+  m <- choice $ map (try . string) mons
-  let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons
+  let i = monIndex m
-  return ("",show i,"1")
+  return ("",show i,"")
 
 today',yesterday,tomorrow :: Parser SmartDate
 today'    = string "today"     >> return ("","","today")

Ledger/Types.hs

@@ -14,7 +14,7 @@ import qualified Data.Map as Map
 
 type SmartDate = (String,String,String)
 
-data DateSpan = DateSpan (Maybe Day) (Maybe Day)
+data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)
 
 type AccountName = String
 

Options.hs

@@ -10,6 +10,8 @@ import Ledger.Types
 import Ledger.Dates
 
 
+versionno   = "0.3pre"
+version     = printf "hledger version %s \n" versionno :: String
 defaultfile = "~/.ledger"
 fileenvvar  = "LEDGER"
 usagehdr    = "Usage: hledger [OPTS] COMMAND [ACCTPATTERNS] [-- DESCPATTERNS]\n" ++
@@ -37,6 +39,7 @@ options = [
  Option ['f'] ["file"]         (ReqArg File "FILE")   filehelp,
  Option ['b'] ["begin"]        (ReqArg Begin "DATE") "report on entries on or after this date",
  Option ['e'] ["end"]          (ReqArg End "DATE")   "report on entries prior to this date",
+ Option ['p'] ["period"]       (ReqArg Period "EXPR") "report on entries during this calendar period",
  Option ['C'] ["cleared"]      (NoArg  Cleared)       "report only on cleared entries",
  Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost basis of commodities",
  Option []    ["depth"]        (ReqArg Depth "N")     "balance report: maximum account depth to show",
@@ -57,13 +60,14 @@ options = [
 
 -- | An option value from a command-line flag.
 data Opt = 
-    File String | 
+    File    {value::String} | 
-    Begin String | 
+    Begin   {value::String} | 
-    End String | 
+    End     {value::String} | 
+    Period  {value::String} | 
     Cleared | 
     CostBasis | 
-    Depth String | 
+    Depth   {value::String} | 
-    Display String | 
+    Display {value::String} | 
     Empty | 
     Real | 
     OptionsAnywhere | 
@@ -74,8 +78,9 @@ data Opt =
     Version
     deriving (Show,Eq)
 
-versionno = "0.3pre"
+-- yow..
-version = printf "hledger version %s \n" versionno :: String
+optValuesForConstructor f opts = concatMap get opts
+    where get o = if f v == o 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
@@ -104,28 +109,24 @@ fixOptDates opts = do
         where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]"
     fixopt _ o            = o
 
--- | Get the ledger file path from options, an environment variable, or a default
+-- | Figure out the date span we should report on, based on any
-ledgerFilePathFromOpts :: [Opt] -> IO String
+-- begin/end/period options provided. This could be really smart but I'm
-ledgerFilePathFromOpts opts = do
+-- just going to look for 1. the first Period or 2. the first Begin and
-  envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile
+-- first End.
-  paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts)
+dateSpanFromOpts :: Day -> [Opt] -> DateSpan
-  return $ last paths
+dateSpanFromOpts refdate opts 
+    | not $ null ps = spanFromPeriodExpr refdate $ head ps
+    | otherwise = DateSpan firstb firste
     where
-      getfile (File s) = [s]
+      ps = optValuesForConstructor Period opts
-      getfile _ = []
+      firstb = listtomaybeday $ optValuesForConstructor Begin opts
+      firste = listtomaybeday $ optValuesForConstructor End opts
+      listtomaybeday [] = Nothing
+      listtomaybeday vs = Just $ parse $ head vs
+      parse s = parsedate $ printf "%04s/%02s/%02s" y m d
+          where (y,m,d) = fromparse $ parsewith smartdate $ s
 
--- | Expand ~ in a file path (does not handle ~name).
+spanFromPeriodExpr refdate = spanFromSmartDateString refdate
-tildeExpand :: FilePath -> IO FilePath
-tildeExpand ('~':[])     = getHomeDirectory
-tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
---handle ~name, requires -fvia-C or ghc 6.8:
---import System.Posix.User
--- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs
---                                pw <- getUserEntryForName user
---                                return (homeDirectory pw ++ path)
-tildeExpand xs           =  return xs
-
-dateSpanFromOpts opts = DateSpan (beginDateFromOpts opts) (endDateFromOpts opts)
 
 -- | Get the value of the begin date option, if any.
 beginDateFromOpts :: [Opt] -> Maybe Day
@@ -153,6 +154,17 @@ endDateFromOpts opts =
       defaultdate = ""
       (y,m,d) = fromparse $ parsewith smartdate $ last endopts
 
+-- | Get the value of the period option, if any.
+periodFromOpts :: [Opt] -> Maybe String
+periodFromOpts opts =
+    if null periodopts 
+    then Nothing
+    else Just $ head periodopts
+    where
+      periodopts = concatMap getperiod opts
+      getperiod (Period s) = [s]
+      getperiod _ = []
+
 -- | Get the value of the depth option, if any.
 depthFromOpts :: [Opt] -> Maybe Int
 depthFromOpts opts =
@@ -175,6 +187,27 @@ displayFromOpts opts =
       getdisplay (Display s) = [s]
       getdisplay _ = []
 
+-- | Get the ledger file path from options, an environment variable, or a default
+ledgerFilePathFromOpts :: [Opt] -> IO String
+ledgerFilePathFromOpts opts = do
+  envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile
+  paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts)
+  return $ last paths
+    where
+      getfile (File s) = [s]
+      getfile _ = []
+
+-- | Expand ~ in a file path (does not handle ~name).
+tildeExpand :: FilePath -> IO FilePath
+tildeExpand ('~':[])     = getHomeDirectory
+tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
+--handle ~name, requires -fvia-C or ghc 6.8:
+--import System.Posix.User
+-- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs
+--                                pw <- getUserEntryForName user
+--                                return (homeDirectory pw ++ path)
+tildeExpand xs           =  return xs
+
 -- | Gather any ledger-style account/description pattern arguments into
 -- two lists.  These are 0 or more account patterns optionally followed by
 -- a separator and then 0 or more description patterns. The separator is

Tests.hs

@@ -346,18 +346,30 @@ registercommand_tests = TestList [
   ,
   "register report with display expression" ~:
   do 
-    "d<[2008/6/2]"  `displayexprgivestxns` ["2008/01/01","2008/06/01"]
+    "d<[2008/6/2]"  `displayexprgives` ["2008/01/01","2008/06/01"]
-    "d<=[2008/6/2]" `displayexprgivestxns` ["2008/01/01","2008/06/01","2008/06/02"]
+    "d<=[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01","2008/06/02"]
-    "d=[2008/6/2]"  `displayexprgivestxns` ["2008/06/02"]
+    "d=[2008/6/2]"  `displayexprgives` ["2008/06/02"]
-    "d>=[2008/6/2]" `displayexprgivestxns` ["2008/06/02","2008/06/03","2008/12/31"]
+    "d>=[2008/6/2]" `displayexprgives` ["2008/06/02","2008/06/03","2008/12/31"]
-    "d>[2008/6/2]"  `displayexprgivestxns` ["2008/06/03","2008/12/31"]
+    "d>[2008/6/2]"  `displayexprgives` ["2008/06/03","2008/12/31"]
-  ]
+  ,
+  "register report with period expression" ~:
+  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` []
+ ]
   where
-    expr `displayexprgivestxns` dates = 
+    expr `displayexprgives` dates = 
         assertequal dates (datesfromregister r)
         where
           r = showRegisterReport [Display expr] [] l
           l = ledgerfromstring [] sample_ledger_str
+    expr `periodexprgives` dates = 
+        assertequal dates (datesfromregister r)
+        where
+          r = showRegisterReport [Period expr] [] l
+          l = ledgerfromstring [] sample_ledger_str
           
 datesfromregister = filter (not . null) .  map (strip . take 10) . lines
 

hledger.hs

@@ -69,11 +69,12 @@ main = do
 -- (or report a parse error). This function makes the whole thing go.
 parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO ()
 parseLedgerAndDo opts args cmd = do
+  day <- today
+  let span = dateSpanFromOpts day opts
+  let runcmd = cmd opts args . cacheLedger apats . filterRawLedger span dpats c r . canonicaliseAmounts costbasis
   ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd
     where
-      runcmd = cmd opts args . cacheLedger apats . filterRawLedger span dpats c r . canonicaliseAmounts costbasis
       (apats,dpats) = parseAccountDescriptionArgs opts args
-      span = dateSpanFromOpts opts
       c = Cleared `elem` opts
       r = Real `elem` opts
       costbasis = CostBasis `elem` opts