diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index d737b7dbe..e517b9561 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -82,35 +82,60 @@ fixSmartDate :: Date -> SmartDate -> Date fixSmartDate refdate sdate = mkDate $ fromGregorian y m d where (y,m,d) = fix sdate + callondate f d = dateComponents $ mkDate $ f $ utctDay $ dateToUTC d fix :: SmartDate -> (Integer,Int,Int) - fix ("","","today") = (ry, rm, rd) - fix ("","this","day") = (ry, rm, rd) - 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 $ prevweek refdate - fix ("","this","week") = dateComponents $ thisweek refdate - fix ("","next","week") = dateComponents $ nextweek 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) + fix ("","","today") = (ry, rm, rd) + fix ("","this","day") = (ry, rm, rd) + fix ("","","yesterday") = callondate prevday refdate + fix ("","last","day") = callondate prevday refdate + fix ("","","tomorrow") = callondate nextday refdate + fix ("","next","day") = callondate nextday refdate + fix ("","last","week") = callondate prevweek refdate + fix ("","this","week") = callondate thisweek refdate + fix ("","next","week") = callondate nextweek refdate + fix ("","last","month") = callondate prevmonth refdate + fix ("","this","month") = callondate thismonth refdate + fix ("","next","month") = callondate nextmonth refdate + fix ("","last","quarter") = callondate prevquarter refdate + fix ("","this","quarter") = callondate thisquarter refdate + fix ("","next","quarter") = callondate nextquarter refdate + fix ("","last","year") = callondate prevyear refdate + fix ("","this","year") = callondate thisyear refdate + fix ("","next","year") = callondate nextyear 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 -prevday, nextday :: Date -> Date -prevday = mkDate . (addDays (-1)) . utctDay . dateToUTC -nextday = mkDate . (addDays 1) . utctDay . dateToUTC -thisweek date = mkDate $ mondayofweekcontaining $ utctDay $ dateToUTC date -prevweek date = mkDate $ mondayofweekbefore $ utctDay $ dateToUTC date -nextweek date = mkDate $ mondayafter $ utctDay $ dateToUTC date +prevday :: Day -> Day +prevday = addDays (-1) +nextday = addDays 1 -mondayafter day = mondayofweekcontaining $ addDays 7 day -mondayofweekbefore day = mondayofweekcontaining $ addDays (-7) day -mondayofweekcontaining day = fromMondayStartWeek y w 1 +thisweek = startofweek +prevweek = startofweek . addDays (-7) +nextweek = startofweek . addDays 7 +startofweek day = fromMondayStartWeek y w 1 where - (y,m,d) = toGregorian day + (y,_,_) = toGregorian day (w,_) = mondayStartWeek day +thismonth = startofmonth +prevmonth = startofmonth . addGregorianMonthsClip (-1) +nextmonth = startofmonth . addGregorianMonthsClip 1 +startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day + +thisquarter = startofquarter +prevquarter = startofquarter . addGregorianMonthsClip (-3) +nextquarter = startofquarter . addGregorianMonthsClip 3 +startofquarter day = fromGregorian y (firstmonthofquarter m) 1 + where + (y,m,_) = toGregorian day + firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 + +thisyear = startofyear +prevyear = startofyear . addGregorianYearsClip (-1) +nextyear = startofyear . addGregorianYearsClip 1 +startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day ---------------------------------------------------------------------- -- parsing @@ -229,7 +254,7 @@ lastthisnextthing = do ,string "next" ] --many1 spacenonewline - many spacenonewline -- allow lastweek for easier shell scripting + many spacenonewline -- allow the space to be omitted for easier scripting p <- choice [ string "day" ,string "week" diff --git a/Tests.hs b/Tests.hs index 9bb4298a0..c80225805 100644 --- a/Tests.hs +++ b/Tests.hs @@ -100,25 +100,35 @@ misc_tests = TestList [ "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` "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 + -- for now at least, a fuzzy date always refers to the start of the period + "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` "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 + "this month" `gives` "2008/11/01" + "last month" `gives` "2008/10/01" + "next month" `gives` "2008/12/01" + "this quarter" `gives` "2008/10/01" + "last quarter" `gives` "2008/07/01" + "next quarter" `gives` "2009/01/01" + "this year" `gives` "2008/01/01" + "last year" `gives` "2007/01/01" + "next year" `gives` "2009/01/01" ] balancereportacctnames_tests = TestList