Refactor calendar
Slava Pestov
parent
5796a18d59
commit
2acfc8fe38
extra
webapps/file
windows/time
|
|
@ -1,14 +1,14 @@
|
|||
USING: arrays calendar kernel math sequences tools.test
|
||||
continuations system io.streams.string ;
|
||||
continuations system ;
|
||||
|
||||
[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 12 32 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 2 30 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2003 2 29 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 -2 9 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 12 0 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 12 1 24 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 12 1 23 60 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
! [ 2004 12 1 23 59 60 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
|
||||
|
||||
[ f ] [ 1900 leap-year? ] unit-test
|
||||
[ t ] [ 1904 leap-year? ] unit-test
|
||||
|
|
@ -16,164 +16,144 @@ continuations system io.streams.string ;
|
|||
[ f ] [ 2001 leap-year? ] unit-test
|
||||
[ f ] [ 2006 leap-year? ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt
|
||||
2006 10 10 0 0 1 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt
|
||||
2006 10 10 0 1 40 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt
|
||||
2006 10 9 23 58 20 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt
|
||||
2006 10 11 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt
|
||||
2006 10 10 0 10 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt
|
||||
2006 10 10 0 10 30 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt
|
||||
2006 10 10 0 0 45 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt
|
||||
2006 10 9 23 59 15 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt
|
||||
2006 10 15 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt
|
||||
2006 10 9 23 50 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt
|
||||
2006 10 9 22 20 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt
|
||||
2006 1 1 1 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt
|
||||
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt
|
||||
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt
|
||||
2006 1 1 12 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt
|
||||
2006 1 4 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt
|
||||
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt
|
||||
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt
|
||||
2004 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt
|
||||
2006 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt
|
||||
2008 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt
|
||||
2007 2 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt
|
||||
2006 2 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt
|
||||
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt
|
||||
2005 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt
|
||||
2005 11 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt
|
||||
2004 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt
|
||||
2004 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt
|
||||
2005 3 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt
|
||||
2003 3 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt
|
||||
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt
|
||||
1906 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt
|
||||
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
|
||||
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
|
||||
[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt
|
||||
2009 1 1 0 0 10 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt
|
||||
1998 12 31 23 59 50 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
|
||||
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
|
||||
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
|
||||
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
|
||||
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
|
||||
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
: checktime+ now dup clone [ rot time+ drop ] keep = ;
|
||||
|
||||
[ 1 ] [
|
||||
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 seconds checktime+ ] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 minutes checktime+ ] unit-test
|
||||
|
||||
[ -1-1/2 ] [
|
||||
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 hours checktime+ ] unit-test
|
||||
|
||||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 days checktime+ ] unit-test
|
||||
|
||||
: check+dt now dup clone [ rot +dt drop ] keep = ;
|
||||
[ t ] [ 5 weeks checktime+ ] unit-test
|
||||
|
||||
[ t ] [ 5 seconds check+dt ] unit-test
|
||||
[ t ] [ 5 months checktime+ ] unit-test
|
||||
|
||||
[ t ] [ 5 minutes check+dt ] unit-test
|
||||
|
||||
[ t ] [ 5 hours check+dt ] unit-test
|
||||
|
||||
[ t ] [ 5 days check+dt ] unit-test
|
||||
|
||||
[ t ] [ 5 weeks check+dt ] unit-test
|
||||
|
||||
[ t ] [ 5 months check+dt ] unit-test
|
||||
|
||||
[ t ] [ 5 years check+dt ] unit-test
|
||||
[ t ] [ 5 years checktime+ ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,20 +1,21 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays hashtables io io.streams.string kernel math
|
||||
math.vectors math.functions math.parser namespaces sequences
|
||||
strings tuples system debugger combinators vocabs.loader
|
||||
calendar.backend structs alien.c-types math.vectors
|
||||
shuffle threads ;
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings tuples system vocabs.loader calendar.backend threads
|
||||
new-slots accessors combinators ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
TUPLE: dt year month day hour minute second ;
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset <timestamp> ;
|
||||
|
||||
C: <dt> dt
|
||||
TUPLE: duration year month day hour minute second ;
|
||||
|
||||
C: <duration> duration
|
||||
|
||||
: month-names
|
||||
{
|
||||
|
|
@ -40,6 +41,8 @@ C: <dt> dt
|
|||
#! length of average month in days
|
||||
30.41666666666667 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
SYMBOL: c
|
||||
|
|
@ -48,6 +51,8 @@ SYMBOL: e
|
|||
SYMBOL: y
|
||||
SYMBOL: m
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
|
|
@ -74,38 +79,31 @@ SYMBOL: m
|
|||
e get 153 m get * 2 + 5 /i - 1+
|
||||
] with-scope ;
|
||||
|
||||
: set-date ( year month day timestamp -- )
|
||||
[ set-timestamp-day ] keep
|
||||
[ set-timestamp-month ] keep
|
||||
set-timestamp-year ;
|
||||
|
||||
: set-time ( hour minute second timestamp -- )
|
||||
[ set-timestamp-second ] keep
|
||||
[ set-timestamp-minute ] keep
|
||||
set-timestamp-hour ;
|
||||
|
||||
: >date< ( timestamp -- year month day )
|
||||
[ timestamp-year ] keep
|
||||
[ timestamp-month ] keep
|
||||
timestamp-day ;
|
||||
{ year>> month>> day>> } get-slots ;
|
||||
|
||||
: >time< ( timestamp -- hour minute second )
|
||||
[ timestamp-hour ] keep
|
||||
[ timestamp-minute ] keep
|
||||
timestamp-second ;
|
||||
{ hour>> minute>> second>> } get-slots ;
|
||||
|
||||
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
|
||||
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
|
||||
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
|
||||
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
|
||||
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
|
||||
: years ( n -- dt ) instant swap >>year ;
|
||||
: months ( n -- dt ) instant swap >>month ;
|
||||
: days ( n -- dt ) instant swap >>day ;
|
||||
: weeks ( n -- dt ) 7 * days ;
|
||||
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
|
||||
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
|
||||
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
|
||||
: milliseconds ( n -- dt ) 1000 /f seconds ;
|
||||
: hours ( n -- dt ) instant swap >>hour ;
|
||||
: minutes ( n -- dt ) instant swap >>minute ;
|
||||
: seconds ( n -- dt ) instant swap >>second ;
|
||||
: milliseconds ( n -- dt ) 1000 / seconds ;
|
||||
|
||||
: julian-day-number>timestamp ( n -- timestamp )
|
||||
julian-day-number>date 0 0 0 0 <timestamp> ;
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
year>> leap-year? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: +year ( timestamp x -- timestamp )
|
||||
GENERIC: +month ( timestamp x -- timestamp )
|
||||
|
|
@ -116,85 +114,103 @@ GENERIC: +second ( timestamp x -- timestamp )
|
|||
|
||||
: /rem ( f n -- q r )
|
||||
#! q is positive or negative, r is positive from 0 <= r < n
|
||||
[ /f floor >integer ] 2keep rem ;
|
||||
[ / floor >integer ] 2keep rem ;
|
||||
|
||||
: float>whole-part ( float -- int float )
|
||||
[ floor >integer ] keep over - ;
|
||||
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
timestamp-year leap-year? ;
|
||||
|
||||
: adjust-leap-year ( timestamp -- timestamp )
|
||||
dup >date< 29 = swap 2 = and swap leap-year? not and [
|
||||
dup >r timestamp-year 3 1 r> [ set-date ] keep
|
||||
] when ;
|
||||
dup day>> 29 = over month>> 2 = pick leap-year? not and and
|
||||
[ 3 >>month 1 >>day ] when ;
|
||||
|
||||
: unless-zero >r dup zero? [ drop ] r> if ; inline
|
||||
|
||||
M: integer +year ( timestamp n -- timestamp )
|
||||
over timestamp-year + swap [ set-timestamp-year ] keep
|
||||
adjust-leap-year ;
|
||||
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
|
||||
|
||||
M: real +year ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 365.2425 * +day swap +year ;
|
||||
[ float>whole-part swapd 365.2425 * +day swap +year ] unless-zero ;
|
||||
|
||||
: months/years ( n -- months years )
|
||||
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
|
||||
|
||||
M: integer +month ( timestamp n -- timestamp )
|
||||
over timestamp-month + 12 /rem
|
||||
dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
|
||||
+year ;
|
||||
[ over month>> + months/years >r >>month r> +year ] unless-zero ;
|
||||
|
||||
M: real +month ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap average-month * +day swap +month ;
|
||||
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
|
||||
|
||||
M: integer +day ( timestamp n -- timestamp )
|
||||
swap [
|
||||
>date< julian-day-number + julian-day-number>timestamp
|
||||
] keep swap >r >time< r> [ set-time ] keep ;
|
||||
[
|
||||
over >date< julian-day-number + julian-day-number>date
|
||||
>r >r >>year r> >>month r> >>day
|
||||
] unless-zero ;
|
||||
|
||||
M: real +day ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 24 * +hour swap +day ;
|
||||
[ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
|
||||
|
||||
: hours/days ( n -- hours days )
|
||||
24 /rem swap ;
|
||||
|
||||
M: integer +hour ( timestamp n -- timestamp )
|
||||
over timestamp-hour + 24 /rem pick set-timestamp-hour
|
||||
+day ;
|
||||
[ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
|
||||
|
||||
M: real +hour ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 60 * +minute swap +hour ;
|
||||
float>whole-part swapd 60 * +minute swap +hour ;
|
||||
|
||||
: minutes/hours ( n -- minutes hours )
|
||||
60 /rem swap ;
|
||||
|
||||
M: integer +minute ( timestamp n -- timestamp )
|
||||
over timestamp-minute + 60 /rem pick
|
||||
set-timestamp-minute +hour ;
|
||||
[ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
|
||||
|
||||
M: real +minute ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 60 * +second swap +minute ;
|
||||
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
|
||||
|
||||
: seconds/minutes ( n -- seconds minutes )
|
||||
60 /rem swap >integer ;
|
||||
|
||||
M: number +second ( timestamp n -- timestamp )
|
||||
over timestamp-second + 60 /rem >r >integer r>
|
||||
pick set-timestamp-second +minute ;
|
||||
[ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
|
||||
|
||||
: +dt ( timestamp dt -- timestamp )
|
||||
dupd
|
||||
[ dt-second +second ] keep
|
||||
[ dt-minute +minute ] keep
|
||||
[ dt-hour +hour ] keep
|
||||
[ dt-day +day ] keep
|
||||
[ dt-month +month ] keep
|
||||
dt-year +year
|
||||
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
|
||||
: (time+)
|
||||
[ second>> +second ] keep
|
||||
[ minute>> +minute ] keep
|
||||
[ hour>> +hour ] keep
|
||||
[ day>> +day ] keep
|
||||
[ month>> +month ] keep
|
||||
[ year>> +year ] keep ; inline
|
||||
|
||||
: make-timestamp ( year month day hour minute second gmt-offset -- timestamp )
|
||||
<timestamp> [ 0 seconds +dt ] keep
|
||||
[ = [ "invalid timestamp" throw ] unless ] keep ;
|
||||
: +slots [ 2apply + ] curry 2keep ; inline
|
||||
|
||||
: make-date ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset make-timestamp ;
|
||||
PRIVATE>
|
||||
|
||||
: array>dt ( vec -- dt ) { dt f } swap append >tuple ;
|
||||
: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
|
||||
GENERIC# time+ 1 ( time dt -- time )
|
||||
|
||||
M: timestamp time+
|
||||
>r clone r> (time+) drop ;
|
||||
|
||||
M: duration time+
|
||||
[ year>> ] +slots
|
||||
[ month>> ] +slots
|
||||
[ day>> ] +slots
|
||||
[ hour>> ] +slots
|
||||
[ minute>> ] +slots
|
||||
[ second>> ] +slots
|
||||
2drop <duration> ;
|
||||
|
||||
: dt>years ( dt -- x )
|
||||
#! Uses average month/year length since dt loses calendar
|
||||
#! data
|
||||
tuple-slots
|
||||
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
|
||||
v/ sum ;
|
||||
0 swap
|
||||
[ year>> + ] keep
|
||||
[ month>> 12 / + ] keep
|
||||
[ day>> 365.2425 / + ] keep
|
||||
[ hour>> 8765.82 / + ] keep
|
||||
[ minute>> 525949.2 / + ] keep
|
||||
second>> 31556952.0 / + ;
|
||||
|
||||
M: duration <=> [ dt>years ] compare ;
|
||||
|
||||
: dt>months ( dt -- x ) dt>years 12 * ;
|
||||
: dt>days ( dt -- x ) dt>years 365.2425 * ;
|
||||
|
|
@ -204,8 +220,9 @@ M: number +second ( timestamp n -- timestamp )
|
|||
: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ;
|
||||
|
||||
: convert-timezone ( timestamp n -- timestamp )
|
||||
[ over timestamp-gmt-offset - hours +dt ] keep
|
||||
over set-timestamp-gmt-offset ;
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
[ over gmt-offset>> - hours time+ ] keep >>gmt-offset
|
||||
] if ;
|
||||
|
||||
: >local-time ( timestamp -- timestamp )
|
||||
gmt-offset convert-timezone ;
|
||||
|
|
@ -216,42 +233,37 @@ M: number +second ( timestamp n -- timestamp )
|
|||
M: timestamp <=> ( ts1 ts2 -- n )
|
||||
[ >gmt tuple-slots ] compare ;
|
||||
|
||||
: timestamp- ( timestamp timestamp -- seconds )
|
||||
: time- ( timestamp timestamp -- seconds )
|
||||
#! Exact calendar-time difference
|
||||
[ >gmt ] 2apply
|
||||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ;
|
||||
1970 1 1 0 0 0 0 <timestamp> ; foldable
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> 1000 /f seconds +dt ;
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
|
||||
: timestamp>millis ( timestamp -- n )
|
||||
unix-1970 timestamp- 1000 * >integer ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds +dt ;
|
||||
|
||||
: timestamp>unix-time ( timestamp -- n )
|
||||
unix-1970 timestamp- >integer ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
timestamp>unix-time 1000 * make-timeval ;
|
||||
|
||||
: timeval>timestamp ( timeval -- timestamp )
|
||||
[ timeval-sec ] keep
|
||||
timeval-usec 1000000 / + unix-time>timestamp ;
|
||||
|
||||
unix-1970 time- 1000 * >integer ;
|
||||
|
||||
: gmt ( -- timestamp )
|
||||
#! GMT time, right now
|
||||
unix-1970 millis 1000 /f seconds +dt ;
|
||||
unix-1970 millis milliseconds time+ ;
|
||||
|
||||
: now ( -- timestamp ) gmt >local-time ;
|
||||
: before ( dt -- -dt ) tuple-slots vneg array>dt ;
|
||||
: from-now ( dt -- timestamp ) now swap +dt ;
|
||||
|
||||
: before ( dt -- -dt )
|
||||
[ year>> neg ] keep
|
||||
[ month>> neg ] keep
|
||||
[ day>> neg ] keep
|
||||
[ hour>> neg ] keep
|
||||
[ minute>> neg ] keep
|
||||
[ second>> neg ] keep
|
||||
<duration> ;
|
||||
|
||||
: from-now ( dt -- timestamp ) now swap time+ ;
|
||||
: ago ( dt -- timestamp ) before from-now ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
|
||||
|
|
@ -268,7 +280,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
GENERIC: days-in-year ( obj -- n )
|
||||
|
||||
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
||||
|
||||
GENERIC: days-in-month ( obj -- n )
|
||||
|
||||
|
|
@ -280,7 +292,7 @@ M: array days-in-month ( obj -- n )
|
|||
] if ;
|
||||
|
||||
M: timestamp days-in-month ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month } get-slots 2array days-in-month ;
|
||||
>date< drop 2array days-in-month ;
|
||||
|
||||
GENERIC: day-of-week ( obj -- n )
|
||||
|
||||
|
|
@ -297,156 +309,20 @@ M: array day-of-year ( array -- n )
|
|||
3dup day-counts rot head-slice sum +
|
||||
swap leap-year? [
|
||||
-roll
|
||||
pick 3 1 make-date >r make-date r>
|
||||
<=> 0 >= [ 1+ ] when
|
||||
pick 3 1 <date> >r <date> r>
|
||||
after=? [ 1+ ] when
|
||||
] [
|
||||
3nip
|
||||
>r 3drop r>
|
||||
] if ;
|
||||
|
||||
M: timestamp day-of-year ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month timestamp-day } get-slots
|
||||
3array day-of-year ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
M: integer day. ( n -- )
|
||||
number>string dup length 2 < [ bl ] when write ;
|
||||
|
||||
M: timestamp day. ( timestamp -- )
|
||||
timestamp-day day. ;
|
||||
|
||||
GENERIC: month. ( obj -- )
|
||||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ] 2keep
|
||||
[ 1 zeller-congruence ] 2keep
|
||||
2array days-in-month day-abbreviations2 " " join print
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ day. ] keep
|
||||
1+ + 7 mod zero? [ nl ] [ bl ] if
|
||||
] with each nl ;
|
||||
|
||||
M: timestamp month. ( timestamp -- )
|
||||
{ timestamp-year timestamp-month } get-slots 2array month. ;
|
||||
|
||||
GENERIC: year. ( obj -- )
|
||||
|
||||
M: integer year. ( n -- )
|
||||
12 [ 1+ 2array month. nl ] with each ;
|
||||
|
||||
M: timestamp year. ( timestamp -- )
|
||||
timestamp-year year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
dup day-of-week day-abbreviations3 nth write ", " write
|
||||
dup timestamp-day number>string write bl
|
||||
dup timestamp-month month-abbreviations nth write bl
|
||||
dup timestamp-year number>string write bl
|
||||
dup timestamp-hour write-00 ":" write
|
||||
dup timestamp-minute write-00 ":" write
|
||||
timestamp-second >fixnum write-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
{
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
dup (timestamp>string)
|
||||
" " write
|
||||
timestamp-gmt-offset write-gmt-offset
|
||||
] with-string-writer ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup timestamp-year number>string write CHAR: - write1
|
||||
dup timestamp-month write-00 CHAR: - write1
|
||||
dup timestamp-day write-00 CHAR: T write1
|
||||
dup timestamp-hour write-00 CHAR: : write1
|
||||
dup timestamp-minute write-00 CHAR: : write1
|
||||
dup timestamp-second >fixnum write-00
|
||||
timestamp-gmt-offset write-rfc3339-gmt-offset ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
[ (timestamp>rfc3339) ] with-string-writer ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
: read-rfc3339-gmt-offset ( -- n )
|
||||
read1 dup CHAR: Z = [ drop 0 ] [
|
||||
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
|
||||
read-00
|
||||
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
|
||||
60 / + *
|
||||
] if ;
|
||||
|
||||
: (rfc3339>timestamp) ( -- timestamp )
|
||||
read-0000 ! year
|
||||
"-" expect
|
||||
read-00 ! month
|
||||
"-" expect
|
||||
read-00 ! day
|
||||
"Tt" expect
|
||||
read-00 ! hour
|
||||
":" expect
|
||||
read-00 ! minute
|
||||
":" expect
|
||||
read-00 ! second
|
||||
read-rfc3339-gmt-offset ! timezone
|
||||
<timestamp> ;
|
||||
|
||||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[ (rfc3339>timestamp) ] with-string-reader ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
[ timestamp-month month-abbreviations nth write ] keep bl
|
||||
[ timestamp-day number>string 2 32 pad-left write ] keep bl
|
||||
dup now [ timestamp-year ] 2apply = [
|
||||
[ timestamp-hour write-00 ] keep ":" write
|
||||
timestamp-minute write-00
|
||||
] [
|
||||
timestamp-year number>string 5 32 pad-left write
|
||||
] if
|
||||
] with-string-writer ;
|
||||
>date< 3array day-of-year ;
|
||||
|
||||
: day-offset ( timestamp m -- timestamp n )
|
||||
over day-of-week - ; inline
|
||||
|
||||
: day-this-week ( timestamp n -- timestamp )
|
||||
day-offset days +dt ;
|
||||
day-offset days time+ ;
|
||||
|
||||
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
|
||||
: monday ( timestamp -- timestamp ) 1 day-this-week ;
|
||||
|
|
@ -457,25 +333,26 @@ M: timestamp year. ( timestamp -- )
|
|||
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
|
||||
|
||||
: beginning-of-day ( timestamp -- new-timestamp )
|
||||
clone dup >r 0 0 0 r>
|
||||
{ set-timestamp-hour set-timestamp-minute set-timestamp-second }
|
||||
set-slots ; inline
|
||||
clone
|
||||
0 >>hour
|
||||
0 >>minute
|
||||
0 >>second ; inline
|
||||
|
||||
: beginning-of-month ( timestamp -- new-timestamp )
|
||||
beginning-of-day 1 over set-timestamp-day ;
|
||||
beginning-of-day 1 >>day ;
|
||||
|
||||
: beginning-of-week ( timestamp -- new-timestamp )
|
||||
beginning-of-day sunday ;
|
||||
|
||||
: beginning-of-year ( timestamp -- new-timestamp )
|
||||
beginning-of-month 1 over set-timestamp-month ;
|
||||
beginning-of-month 1 >>month ;
|
||||
|
||||
: seconds-since-midnight ( timestamp -- x )
|
||||
dup beginning-of-day timestamp- ;
|
||||
dup beginning-of-day time- ;
|
||||
|
||||
M: timestamp sleep-until timestamp>millis sleep-until ;
|
||||
|
||||
M: dt sleep from-now sleep-until ;
|
||||
M: duration sleep from-now sleep-until ;
|
||||
|
||||
{
|
||||
{ [ unix? ] [ "calendar.unix" ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,22 @@
|
|||
IN: temporary
|
||||
USING: calendar.format tools.test io.streams.string ;
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ -1-1/2 ] [
|
||||
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,138 @@
|
|||
IN: calendar.format
|
||||
USING: math math.parser kernel sequences io calendar
|
||||
accessors arrays io.streams.string combinators ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
M: integer day. ( n -- )
|
||||
number>string dup length 2 < [ bl ] when write ;
|
||||
|
||||
M: timestamp day. ( timestamp -- )
|
||||
day>> day. ;
|
||||
|
||||
GENERIC: month. ( obj -- )
|
||||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ] 2keep
|
||||
[ 1 zeller-congruence ] 2keep
|
||||
2array days-in-month day-abbreviations2 " " join print
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ day. ] keep
|
||||
1+ + 7 mod zero? [ nl ] [ bl ] if
|
||||
] with each nl ;
|
||||
|
||||
M: timestamp month. ( timestamp -- )
|
||||
{ year>> month>> } get-slots 2array month. ;
|
||||
|
||||
GENERIC: year. ( obj -- )
|
||||
|
||||
M: integer year. ( n -- )
|
||||
12 [ 1+ 2array month. nl ] with each ;
|
||||
|
||||
M: timestamp year. ( timestamp -- )
|
||||
year>> year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
dup day-of-week day-abbreviations3 nth write ", " write
|
||||
dup day>> number>string write bl
|
||||
dup month>> month-abbreviations nth write bl
|
||||
dup year>> number>string write bl
|
||||
dup hour>> write-00 ":" write
|
||||
dup minute>> write-00 ":" write
|
||||
second>> >integer write-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
{
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
dup (timestamp>string)
|
||||
" " write
|
||||
gmt-offset>> write-gmt-offset
|
||||
] with-string-writer ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup year>> number>string write CHAR: - write1
|
||||
dup month>> write-00 CHAR: - write1
|
||||
dup day>> write-00 CHAR: T write1
|
||||
dup hour>> write-00 CHAR: : write1
|
||||
dup minute>> write-00 CHAR: : write1
|
||||
dup second>> >fixnum write-00
|
||||
gmt-offset>> write-rfc3339-gmt-offset ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
[ (timestamp>rfc3339) ] with-string-writer ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
: read-rfc3339-gmt-offset ( -- n )
|
||||
read1 dup CHAR: Z = [ drop 0 ] [
|
||||
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
|
||||
read-00
|
||||
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
|
||||
60 / + *
|
||||
] if ;
|
||||
|
||||
: (rfc3339>timestamp) ( -- timestamp )
|
||||
read-0000 ! year
|
||||
"-" expect
|
||||
read-00 ! month
|
||||
"-" expect
|
||||
read-00 ! day
|
||||
"Tt" expect
|
||||
read-00 ! hour
|
||||
":" expect
|
||||
read-00 ! minute
|
||||
":" expect
|
||||
read-00 ! second
|
||||
read-rfc3339-gmt-offset ! timezone
|
||||
<timestamp> ;
|
||||
|
||||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[ (rfc3339>timestamp) ] with-string-reader ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
[ month>> month-abbreviations nth write ] keep bl
|
||||
[ day>> number>string 2 32 pad-left write ] keep bl
|
||||
dup now [ year>> ] 2apply = [
|
||||
[ hour>> write-00 ] keep ":" write
|
||||
minute>> write-00
|
||||
] [
|
||||
year>> number>string 5 32 pad-left write
|
||||
] if
|
||||
] with-string-writer ;
|
||||
|
|
@ -11,6 +11,9 @@ SYMBOL: doc-root
|
|||
: serving-path ( filename -- filename )
|
||||
"" or doc-root get swap path+ ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds time+ ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-modified unix-time>timestamp timestamp>http-string ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,5 +2,5 @@ USING: calendar calendar.windows kernel tools.test ;
|
|||
|
||||
[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
|
||||
[ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test
|
||||
[ t ] [ windows-1601 400 years +dt [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
|
||||
[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: windows.time
|
|||
FILETIME-dwHighDateTime >64bit ;
|
||||
|
||||
: windows-time>timestamp ( n -- timestamp )
|
||||
10000000 /i seconds windows-1601 swap +dt ;
|
||||
10000000 /i seconds windows-1601 swap time+ ;
|
||||
|
||||
: windows-time ( -- n )
|
||||
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
|
||||
|
|
|
|||
Loading…
Reference in New Issue