calendar: Add some more words that should exist.

Clean up some of the clone/setter code.

Inspiration from Luxon JS.

diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
index fef64a0f289d5784b621cad532f29374ceadf127..a5aa8ece366923e7cf65db521c4871a4b17d1c19 100644 (file)
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@@ -200,3 +200,17 @@ IN: calendar
 { 16 } [ 2019 4 17 <date> week-number ] unit-test
 
 { 53 } [ 2021 1 1 <date> week-number ] unit-test
+
+{ 53 } [ 2004 weeks-in-week-year ] unit-test
+{ 52 } [ 2013 weeks-in-week-year ] unit-test
+
+{ f } [ now dup beginning-of-day eq? ] unit-test
+{ f } [ now dup end-of-day eq? ] unit-test
+{ t } [ now dup end-of-day! eq? ] unit-test
+{ f } [ now dup beginning-of-month eq? ] unit-test
+{ f } [ now dup end-of-month eq? ] unit-test
+{ f } [ now dup beginning-of-year eq? ] unit-test
+{ f } [ now dup end-of-year eq? ] unit-test
+
+{ f } [ now dup midnight eq? ] unit-test
+{ t } [ now dup midnight! eq? ] unit-test
\ No newline at end of file

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index e8c0495665de9dc057c7b49684858693b9dde14a..ea86f416a7bfb3800c3bd85a0000de35e0409d31 100644 (file)
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -396,26 +396,46 @@ M: timestamp days-in-year year>> days-in-year ;
 : day-of-year ( timestamp -- n )
     >date< (day-of-year) ;
 
+: midnight! ( timestamp -- new-timestamp )
+    0 >>hour 0 >>minute 0 >>second ; inline
+
 : midnight ( timestamp -- new-timestamp )
-    clone 0 >>hour 0 >>minute 0 >>second ; inline
+    clone midnight! ; inline
 
 : noon ( timestamp -- new-timestamp )
     midnight 12 >>hour ; inline
 
 : today ( -- timestamp )
-    now midnight ; inline
+    now midnight! ; inline
 
 : tomorrow ( -- timestamp )
-    1 days hence midnight ; inline
+    1 days hence midnight! ; inline
 
 : yesterday ( -- timestamp )
-    1 days ago midnight ; inline
+    1 days ago midnight! ; inline
+
+GENERIC: beginning-of-day ( object -- new-timestamp )
+M: timestamp beginning-of-day midnight ;
+
+: end-of-day! ( timestamp -- timestamp )
+    23 >>hour 59 >>minute 59+999/1000 >>second ;
+
+GENERIC: end-of-day ( object -- new-timestamp )
+M: timestamp end-of-day clone end-of-day! ;
 
 : beginning-of-month ( timestamp -- new-timestamp )
     midnight 1 >>day ; inline
 
 : end-of-month ( timestamp -- new-timestamp )
-    [ midnight ] [ days-in-month ] bi >>day ;
+    [ end-of-day ] [ days-in-month ] bi >>day ;
+
+GENERIC: beginning-of-year ( object -- new-timestamp )
+M: timestamp beginning-of-year beginning-of-month 1 >>month ;
+M: integer beginning-of-year <year> ;
+
+GENERIC: end-of-year ( object -- new-timestamp )
+M: timestamp end-of-year end-of-day 12 >>month 31 >>day ;
+M: integer end-of-year 12 31 <date> end-of-day! ;
 
 <PRIVATE
 
@@ -474,6 +494,19 @@ M: timestamp october clone 10 >>month ;
 M: timestamp november clone 11 >>month ;
 M: timestamp december clone 12 >>month ;
 
+: <january> ( year day -- timestamp ) 1 swap <date> ; inline
+: <february> ( year day -- timestamp ) 2 swap <date> ; inline
+: <march> ( year day -- timestamp ) 3 swap <date> ; inline
+: <april> ( year day -- timestamp ) 4 swap <date> ; inline
+: <may> ( year day -- timestamp ) 5 swap <date> ; inline
+: <june> ( year day -- timestamp ) 6 swap <date> ; inline
+: <july> ( year day -- timestamp ) 7 swap <date> ; inline
+: <august> ( year day -- timestamp ) 8 swap <date> ; inline
+: <september> ( year day -- timestamp ) 9 swap <date> ; inline
+: <october> ( year day -- timestamp ) 10 swap <date> ; inline
+: <november> ( year day -- timestamp ) 11 swap <date> ; inline
+: <december> ( year day -- timestamp ) 12 swap <date> ; inline
+
 : sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
 : monday ( timestamp -- new-timestamp ) 1 day-this-week ;
 : tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
@@ -518,14 +551,6 @@ M: timestamp december clone 12 >>month ;
 : pm ( timestamp n -- new-timestamp )
     0 12 [a,b] check-interval 12 + o'clock ;
 
-GENERIC: beginning-of-year ( object -- new-timestamp )
-M: timestamp beginning-of-year beginning-of-month 1 >>month ;
-M: integer beginning-of-year <year> ;
-
-GENERIC: end-of-year ( object -- new-timestamp )
-M: timestamp end-of-year 12 >>month 31 >>day ;
-M: integer end-of-year 12 31 <date> ;
-
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ; inline
 
@@ -548,6 +573,16 @@ M: integer end-of-year 12 31 <date> ;
         [ nip ]
     } case ;
 
+: quarter ( timestamp -- [1,4] )
+    month>> 3 /mod [ drop 1 + ] unless-zero ; inline
+
+GENERIC: weeks-in-week-year ( obj -- n )
+M: integer weeks-in-week-year
+    { [ 1 1 <date> thursday? ] [ 12 31 <date> thursday? ] } 1|| 53 52 ? ;
+
+M: timestamp weeks-in-week-year
+    { [ january 1 >>day thursday? ] [ december 31 >>day thursday? ] } 1|| 53 52 ? ;
+
 {
     { [ os unix? ] [ "calendar.unix" ] }
     { [ os windows? ] [ "calendar.windows" ] }

diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor
index bf1668ebd721e7a128b7832a559385bc376bc423..f306452a7ba1cd47ec1de890f57d3cb7e4fcaaa0 100644 (file)
--- a/basis/calendar/format/format.factor
+++ b/basis/calendar/format/format.factor
@@ -159,6 +159,25 @@ M: timestamp year.
 : timestamp>rfc3339 ( timestamp -- str )
     [ (timestamp>rfc3339) ] with-string-writer ;
 
+: (write-rfc2822-gmt-offset) ( duration -- )
+    [ hh ":" write ] [ mm ] bi ;
+
+: write-rfc2822-gmt-offset ( duration -- )
+    dup instant <=> {
+        { +lt+ [ "-" write before (write-rfc2822-gmt-offset) ] }
+        { +gt+ [ "+" write (write-rfc2822-gmt-offset) ] }
+        { +eq+ [ "+" write (write-rfc2822-gmt-offset) ] }
+    } case ;
+
+: (timestamp>rfc2822) ( timestamp -- )
+    {
+        DAY ", " DD " " MONTH " " YYYY " " hh ":" mm ":" ss " "
+        [ gmt-offset>> write-rfc2822-gmt-offset ]
+    } formatted ;
+
+: timestamp>rfc2822 ( timestamp -- str )
+    [ (timestamp>rfc2822) ] with-string-writer ;
+
 : (timestamp>ymd) ( timestamp -- )
     { YYYY "-" MM "-" DD } formatted ;