refactoring date parsing, FuzzyDate

Ledger/Dates.hs

@@ -38,6 +38,12 @@ instance Show Date where
 instance Show DateTime where 
    show (DateTime t) = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" t
 
+-- | A fuzzy date is either a partially-specified or a relative date.
+-- We represent it as a triple of strings such as
+-- ("2008","01","01") or ("2008","","") or ("","","tomorrow") or 
+-- ("","last|this|next","day|week|month|quarter|year").
+type FuzzyDate = (String,String,String)
+
 mkDate :: Day -> Date
 mkDate day = Date (localTimeToUTC utc (LocalTime day midnight))
 

Ledger/Parse.hs

@@ -482,6 +482,7 @@ ledgerfromtimelog = do
 
 
 -- misc parsing
+
 {-| 
 Parse a date in any of the formats allowed in ledger's period expressions,
 and maybe some others:
@@ -495,11 +496,10 @@ and maybe some others:
 > yesterday, today, tomorrow
 > (not yet) this/next/last week/day/month/quarter/year
 
-Returns a triple of possibly empty strings for year, month and day
-(defaults are supplied later in the IO layer.)
-Note: only recognises month names in lowercase.
+Returns a FuzzyDate, to be converted to a full date later, in the IO
+layer.  Note: assumes any text in the parse stream has been lowercased.
 -}
-smartdate :: Parser (String,String,String)
+smartdate :: Parser FuzzyDate
 smartdate = do
   let dateparsers = [ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow]
   (y,m,d) <- choice $ map try dateparsers
@@ -507,7 +507,7 @@ smartdate = do
 
 datesepchar = oneOf "/-."
 
-ymd :: Parser (String,String,String)
+ymd :: Parser FuzzyDate
 ymd = do
   y <- many1 digit
   datesepchar
@@ -518,7 +518,7 @@ ymd = do
   guard (read d <= 31)
   return (y,m,d)
 
-ym :: Parser (String,String,String)
+ym :: Parser FuzzyDate
 ym = do
   y <- many1 digit
   guard (read y > 12)
@@ -527,19 +527,19 @@ ym = do
   guard (read m <= 12)
   return (y,m,"1")
 
-y :: Parser (String,String,String)
+y :: Parser FuzzyDate
 y = do
   y <- many1 digit
   guard (read y >= 1000)
   return (y,"1","1")
 
-d :: Parser (String,String,String)
+d :: Parser FuzzyDate
 d = do
   d <- many1 digit
   guard (read d <= 31)
   return ("","",d)
 
-md :: Parser (String,String,String)
+md :: Parser FuzzyDate
 md = do
   m <- many1 digit
   guard (read m <= 12)
@@ -553,22 +553,40 @@ months = ["january","february","march","april","may","june",
 
 mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
 
-month :: Parser (String,String,String)
+month :: Parser FuzzyDate
 month = do
   m <- choice $ map string months
   let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months
   return ("",show i,"1")
 
-mon :: Parser (String,String,String)
+mon :: Parser FuzzyDate
 mon = do
   m <- choice $ map string mons
   let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons
   return ("",show i,"1")
 
+today',yesterday,tomorrow :: Parser FuzzyDate
 today'    = string "today"     >> return ("","","today")
 yesterday = string "yesterday" >> return ("","","yesterday")
 tomorrow  = string "tomorrow"  >> return ("","","tomorrow")
 
+lastthisnextthing :: Parser FuzzyDate
+lastthisnextthing = do
+  r <- choice [
+        string "last"
+       ,string "this"
+       ,string "next"
+      ]
+  many1 spacenonewline
+  p <- choice [
+        string "day"
+       ,string "week"
+       ,string "month"
+       ,string "quarter"
+       ,string "year"
+      ]
+  return ("",r,p)
+
 
 type TransactionMatcher = Transaction -> Bool
 

Options.hs

@@ -88,36 +88,46 @@ parseArguments = do
     (opts,[],[])       -> do {opts' <- fixDates opts; return (opts',[],[])}
     (opts,_,errs)      -> ioError (userError (concat errs ++ usage))
 
--- | Convert any fuzzy/relative dates within these option values to
--- explicit ones, based on today's date.
+-- | Convert any fuzzy dates within these option values to explicit ones,
+-- based on today's date.
 fixDates :: [Opt] -> IO [Opt]
 fixDates opts = do
   t <- today
   return $ map (fixopt t) opts
   where
-    fixopt t (Begin s)   = Begin $ fixdate t s
-    fixopt t (End s)     = End $ fixdate t s
+    fixopt t (Begin s)   = Begin $ fixdatestr t s
+    fixopt t (End s)     = End $ fixdatestr t s
     fixopt t (Display s) = -- hacky
-        Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddate s
-        where fixbracketeddate s = "[" ++ (fixdate t $ init $ tail s) ++ "]"
+        Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s
+        where fixbracketeddatestr s = "[" ++ (fixdatestr t $ init $ tail s) ++ "]"
     fixopt _ o            = o
 
--- | Convert a fuzzy date string to an explicit yyyy/mm/dd date, using the
--- provided today's date for defaults.
-fixdate :: Date -> String -> String
-fixdate t s = printf "%04s/%02s/%02s" y' m' d'
+-- | Convert a fuzzy date string to an explicit yyyy/mm/dd string using
+-- the provided date as reference point.
+fixdatestr :: Date -> String -> String
+fixdatestr t s = printf "%04d/%02d/%02d" y m d
     where
-      (ty,tm,td) = dateComponents t
-      (y,m,d) = fromparse $ parsewith smartdate $ map toLower s
-      (y',m',d') = case (y,m,d) of 
-                     ("","","today") -> (show ty,show tm,show td)
-                     ("","","yesterday") -> (show y, show m, show d) 
-                         where (y,m,d) = toGregorian $ addDays (-1) $ fromGregorian ty tm td
-                     ("","","tomorrow") -> (show y, show m, show d) 
-                         where (y,m,d) = toGregorian $ addDays 1 $ fromGregorian ty tm td
-                     ("","",d)       -> (show ty,show tm,d)
-                     ("",m,d)        -> (show ty,m,d)
-                     otherwise       -> (y,m,d)
+      pdate = fromparse $ parsewith smartdate $ map toLower s
+      (y,m,d) = dateComponents $ fixFuzzyDate t pdate
+
+-- | Convert a FuzzyDate to an absolute date using the provided date as
+-- reference point.
+fixFuzzyDate :: Date -> FuzzyDate -> Date
+fixFuzzyDate refdate pdate = mkDate $ fromGregorian y m d
+    where
+      (y,m,d) = fix pdate
+      fix :: FuzzyDate -> (Integer,Int,Int)
+      fix ("","","today")     = (ry, rm, rd)
+      fix ("","","yesterday") = dateComponents $ lastday refdate
+      fix ("","","tomorrow")  = dateComponents $ nextday refdate
+      fix ("","",d)           = (ry, rm, read d)
+      fix ("",m,d)            = (ry, read m, read d)
+      fix (y,m,d)             = (read y, read m, read d)
+      (ry,rm,rd) = dateComponents refdate
+
+lastday, nextday :: Date -> Date
+lastday = mkDate . (addDays (-1)) . utctDay . dateToUTC
+nextday = mkDate . (addDays 1) . utctDay . dateToUTC
 
 -- | Get the ledger file path from options, an environment variable, or a default
 ledgerFilePathFromOpts :: [Opt] -> IO String

Tests.hs

@@ -100,7 +100,7 @@ misc_tests = TestList [
   "smartparsedate"     ~: do
     t <- today
     let (ty,tm,td) = dateComponents t
-    let str `gives` datestr = assertequal datestr (fixdate t str)
+    let str `gives` datestr = assertequal datestr (fixdatestr t str)
     "1999-12-02" `gives` "1999/12/02"
     "1999.12.02" `gives` "1999/12/02"
     "1999/3/2"   `gives` "1999/03/02"