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