hacking in more date parsing.. today/tomorrow/yesterday

Ledger/Parse.hs

@@ -492,8 +492,8 @@ and maybe some others:
 > 10/1
 > 21
 > october, oct
-> this/next/last week/day/month/quarter/year
 > yesterday, today, tomorrow
+> this/next/last week/day/month/quarter/year
 
 Note: only recognises month names in lowercase.
 -}
@@ -507,9 +507,9 @@ smartdate = do
              ,try d
              ,try month
              ,try mon
---              ,try today
---              ,try yesterday
---              ,try tomorrow
+             ,try parsetoday
+             ,try yesterday
+             ,try tomorrow
 --              ,try thiswhatever
 --              ,try nextwhatever
 --              ,try lastwhatever
@@ -577,6 +577,12 @@ mon = do
   let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons
   return ("",show i,"1")
 
+parsetoday = string "today" >> return ("","","today")
+yesterday = string "yesterday" >> return ("","","yesterday")
+tomorrow = string "tomorrow" >> return ("","","tomorrow")
+
+
+
 type TransactionMatcher = Transaction -> Bool
 
 -- | Parse a --display expression which is a simple date predicate,

Options.hs

@@ -97,25 +97,31 @@ parseArguments = do
 -- explicit ones, based on today's date.
 fixDates :: [Opt] -> IO [Opt]
 fixDates opts = do
-  ds <- today >>= return . dateComponents
-  return $ map (fixopt ds) opts
+  t <- today
+  return $ map (fixopt t) opts
   where
-    fixopt ds (Begin s)   = Begin $ fixdate ds s
-    fixopt ds (End s)     = End $ fixdate ds s
-    fixopt ds (Display s) = -- hacky
+    fixopt t (Begin s)   = Begin $ fixdate t s
+    fixopt t (End s)     = End $ fixdate t s
+    fixopt t (Display s) = -- hacky
         Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddate s
-        where fixbracketeddate s = "[" ++ (fixdate ds $ init $ tail s) ++ "]"
+        where fixbracketeddate s = "[" ++ (fixdate 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 :: (Integer,Int,Int) -> String -> String
-fixdate (thisy,thism,thisd) s = printf "%04s/%02s/%02s" y' m' d'
+fixdate :: Date -> String -> String
+fixdate t s = printf "%04s/%02s/%02s" 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 
-                     ("","",d) -> (show thisy,show thism,d)
-                     ("",m,d)  -> (show thisy,m,d)
+                     ("","","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)
 
 -- | Get the ledger file path from options, an environment variable, or a default

Tests.hs

@@ -98,18 +98,24 @@ misc_tests = TestList [
     assertparseequal timelog1 (parsewith timelog timelog1_str)
   ,                  
   "smartparsedate"     ~: do
-    ds@(y,m,d) <- today >>= return . dateComponents
-    let str `gives` datestr = assertequal datestr (fixdate ds str)
+    t <- today
+    let (ty,tm,td) = dateComponents t
+    let str `gives` datestr = assertequal datestr (fixdate t str)
     "1999-12-02" `gives` "1999/12/02"
     "1999.12.02" `gives` "1999/12/02"
     "1999/3/2"   `gives` "1999/03/02"
     "2008/2"     `gives` "2008/02/01"
     "20/2"       `gives` "0020/02/01"
     "1000"       `gives` "1000/01/01"
-    "4/2"        `gives` (printf "%04d/04/02" y)
-    "2"          `gives` (printf "%04d/%02d/02" y m)
-    "January"    `gives` (printf "%04d/01/01" y)
-    "feb"        `gives` (printf "%04d/02/01" y)
+    "4/2"        `gives` (printf "%04d/04/02" ty)
+    "2"          `gives` (printf "%04d/%02d/02" ty tm)
+    "January"    `gives` (printf "%04d/01/01" ty)
+    "feb"        `gives` (printf "%04d/02/01" ty)
+    "today"      `gives` (printf "%04d/%02d/%02d" ty tm td)
+    let (y,m,d) = toGregorian $ addDays (-1) $ fromGregorian ty tm td
+    "yesterday"  `gives` (printf "%04d/%02d/%02d" y m d)
+    let (y,m,d) = toGregorian $ addDays 1 $ fromGregorian ty tm td
+    "tomorrow"   `gives` (printf "%04d/%02d/%02d" y m d)
   ]
 
 balancereportacctnames_tests = TestList