this/next/last day/week

Ledger/Dates.hs

@@ -16,6 +16,9 @@ where
 import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.Calendar
+import Data.Time.Calendar.MonthDay
+import Data.Time.Calendar.OrdinalDate
+import Data.Time.Calendar.WeekDate
 import Data.Time.LocalTime
 import System.Locale (defaultTimeLocale)
 import Text.Printf
@@ -82,11 +85,11 @@ fixSmartDate refdate sdate = mkDate $ fromGregorian y m d
       fix :: SmartDate -> (Integer,Int,Int)
       fix ("","","today")     = (ry, rm, rd)
       fix ("","this","day")   = (ry, rm, rd)
-      fix ("","","yesterday") = dateComponents $ lastday refdate
-      fix ("","last","day")   = dateComponents $ lastday refdate
+      fix ("","","yesterday") = dateComponents $ prevday refdate
+      fix ("","last","day")   = dateComponents $ prevday refdate
       fix ("","","tomorrow")  = dateComponents $ nextday refdate
       fix ("","next","day")   = dateComponents $ nextday refdate
-      fix ("","last","week")  = dateComponents $ lastweek refdate
+      fix ("","last","week")  = dateComponents $ prevweek refdate
       fix ("","this","week")  = dateComponents $ thisweek refdate
       fix ("","next","week")  = dateComponents $ nextweek refdate
       fix ("","",d)           = (ry, rm, read d)
@@ -94,12 +97,20 @@ fixSmartDate refdate sdate = mkDate $ fromGregorian y m 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
+prevday, nextday :: Date -> Date
+prevday = mkDate . (addDays (-1)) . utctDay . dateToUTC
 nextday = mkDate . (addDays 1) . utctDay . dateToUTC
-lastweek = mkDate . (addDays (-7)) . utctDay . dateToUTC
-thisweek = mkDate . (addDays 0) . utctDay . dateToUTC
-nextweek = mkDate . (addDays 7) . utctDay . dateToUTC
+thisweek date = mkDate $ mondayofweekcontaining $ utctDay $ dateToUTC date
+prevweek date = mkDate $ mondayofweekbefore $ utctDay $ dateToUTC date
+nextweek date = mkDate $ mondayafter $ utctDay $ dateToUTC date
+
+mondayafter day = mondayofweekcontaining $ addDays 7 day
+mondayofweekbefore day = mondayofweekcontaining $ addDays (-7) day
+mondayofweekcontaining day = fromMondayStartWeek y w 1
+    where
+      (y,m,d) = toGregorian day
+      (w,_) = mondayStartWeek day
+
 
 ----------------------------------------------------------------------
 -- parsing
@@ -139,8 +150,8 @@ Assumes any text in the parse stream has been lowercased.
 -}
 smartdate :: Parser SmartDate
 smartdate = do
-  let dateparsers = [ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow
-                     -- lastthisnextthing
+  let dateparsers = [ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow,
+                     lastthisnextthing
                     ]
   (y,m,d) <- choice $ map try dateparsers
   return $ (y,m,d)
@@ -217,7 +228,8 @@ lastthisnextthing = do
        ,string "this"
        ,string "next"
       ]
-  many1 spacenonewline
+  --many1 spacenonewline
+  many spacenonewline  -- allow lastweek for easier shell scripting
   p <- choice [
         string "day"
        ,string "week"

Tests.hs

@@ -97,28 +97,28 @@ misc_tests = TestList [
   "timeLog" ~: do
     assertparseequal timelog1 (parsewith timelog timelog1_str)
   ,                  
-  "smartparsedate"     ~: do
-    t <- today
-    let (ty,tm,td) = dateComponents t
-    let str `gives` datestr = assertequal datestr (fixSmartDateStr t str)
+  "smart dates"     ~: do
+    let todaysdate = parsedate "2008/11/26" -- wednesday
+    let str `gives` datestr = assertequal datestr (fixSmartDateStr todaysdate 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" 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)
---     "this day"   `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)
---     "last day"   `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)
---     "next day"   `gives` (printf "%04d/%02d/%02d" y m d)
+    "4/2"        `gives` "2008/04/02"
+    "2"          `gives` "2008/11/02"
+    "January"    `gives` "2008/01/01"
+    "feb"        `gives` "2008/02/01"
+    "today"      `gives` "2008/11/26"
+    "yesterday"  `gives` "2008/11/25"
+    "tomorrow"   `gives` "2008/11/27"
+    "this day"   `gives` "2008/11/26"
+    "last day"   `gives` "2008/11/25"
+    "next day"   `gives` "2008/11/27"
+    "this week"  `gives` "2008/11/24" -- last monday
+    "last week"  `gives` "2008/11/17" -- previous monday
+    "next week"  `gives` "2008/12/01" -- next monday
   ]
 
 balancereportacctnames_tests = TestList