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

this/next/last day/week

Browse Source
This commit is contained in:
Simon Michael 2008-11-27 01:49:13 +00:00
parent 884ebf2979
commit 7858ed1327
2 changed files with 39 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Ledger/Dates.hs
View File

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

32
Tests.hs
View File

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