slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

this/last/next month/quarter/year

Browse Source
This commit is contained in:
Simon Michael 2008-11-27 02:49:22 +00:00
parent 7858ed1327
commit b7616562d9
2 changed files with 77 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
Ledger/Dates.hs
View File

@ -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"

48
Tests.hs
View File

@ -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