From 7858ed132765d381ae6d1a6424337a97f989f0f8 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Thu, 27 Nov 2008 01:49:13 +0000
Subject: [PATCH] this/next/last day/week

---
 Ledger/Dates.hs | 34 +++++++++++++++++++++++-----------
 Tests.hs        | 32 ++++++++++++++++----------------
 2 files changed, 39 insertions(+), 27 deletions(-)

diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs
index 04269f59b..d737b7dbe 100644
--- a/Ledger/Dates.hs
+++ b/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"
diff --git a/Tests.hs b/Tests.hs
index 8287ee2bc..9bb4298a0 100644
--- a/Tests.hs
+++ b/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