calendar: value checking to make it hard to create invalid timestamps

basis/calendar/calendar-docs.factor

@@ -304,14 +304,6 @@ HELP: before
     }
 } ;
 
-HELP: <zero>
-{ $values { "timestamp" timestamp } }
-{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
-
-HELP: valid-timestamp?
-{ $values { "timestamp" timestamp } { "?" boolean } }
-{ $description "Tests if a timestamp is valid or not." } ;
-
 HELP: unix-1970
 { $values { "timestamp" timestamp } }
 { $description "Returns the beginning of UNIX time, or midnight, January 1, 1970." } ;

basis/calendar/calendar-tests.factor

@@ -1,15 +1,17 @@
 USING: accessors kernel math.order random threads tools.test ;
 IN: calendar
 
-{ f } [ 2004 12 32 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 12 32 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004  2 30 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004  2 30 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2003  2 29 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2003  2 29 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004 -2  9 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 -2  9 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004 12  0 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 12  0 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004 12  1 24  0  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 12  1 24  0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004 12  1 23 60  0 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 12  1 23 60  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ f } [ 2004 12  1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
+[ 2004 12  1 23 59 60 instant <timestamp> ] [ not-in-interval? ] must-fail-with
-{ t } [ now valid-timestamp? ] unit-test
+{ } [
+    2014 12 1 23 59 59+99/100 instant <timestamp> drop
+] unit-test
 
 { f } [ 1900 leap-year? ] unit-test
 { t } [ 1904 leap-year? ] unit-test
@@ -186,3 +188,9 @@ IN: calendar
 
 { 0 }
 [ gmt gmt-offset>> duration>seconds ] unit-test
+
+! am
+[ now 30 am ] [ not-in-interval? ] must-fail-with
+
+! pm
+[ now 30 pm ] [ not-in-interval? ] must-fail-with

basis/calendar/calendar.factor

@@ -2,10 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.tuple combinators
 combinators.short-circuit kernel locals math math.functions
-math.order sequences summary system vocabs vocabs.loader
+math.intervals math.order sequences summary system vocabs vocabs.loader
 assocs ;
 IN: calendar
 
+ERROR: not-in-interval value interval ;
+
+: check-interval ( value interval -- value )
+    2dup interval-contains? [ drop ] [ not-in-interval ] if ;
+
 HOOK: gmt-offset os ( -- hours minutes seconds )
 
 HOOK: gmt os ( -- timestamp )
@@ -31,7 +36,27 @@ TUPLE: timestamp
     { second real }
     { gmt-offset duration } ;
 
-C: <timestamp> timestamp
+CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
+
+GENERIC: leap-year? ( obj -- ? )
+
+M: integer leap-year? ( year -- ? )
+    dup 100 divisor? 400 4 ? divisor? ;
+
+M: timestamp leap-year? ( timestamp -- ? )
+    year>> leap-year? ;
+
+: (days-in-month) ( year month -- n )
+    dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
+
+:: <timestamp> ( year month day hour minute second gmt-offset -- timestamp )
+    year
+    month 1 12 [a,b] check-interval
+    day 1 year month (days-in-month) [a,b] check-interval
+    hour 0 23 [a,b] check-interval
+    minute 0 59 [a,b] check-interval
+    second 0 60 [a,b) check-interval
+    gmt-offset timestamp boa ;
 
 M: timestamp clone (clone) [ clone ] change-gmt-offset ;
 
@@ -50,8 +75,6 @@ M: timestamp clone (clone) [ clone ] change-gmt-offset ;
 : <year-gmt> ( year -- timestamp )
     1 1 <date-gmt> ; inline
 
-CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
-
 CONSTANT: average-month 30+5/12
 CONSTANT: months-per-year 12
 CONSTANT: days-per-year 3652425/10000
@@ -123,14 +146,6 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;
 
-GENERIC: leap-year? ( obj -- ? )
-
-M: integer leap-year? ( year -- ? )
-    dup 100 divisor? 400 4 ? divisor? ;
-
-M: timestamp leap-year? ( timestamp -- ? )
-    year>> leap-year? ;
-
 <PRIVATE
 
 GENERIC: +year ( timestamp x -- timestamp )
@@ -327,13 +342,6 @@ M: duration time-
         2drop <duration>
     ] if ;
 
-: <zero> ( -- timestamp )
-    0 0 0 <date-gmt> ; inline
-
-: valid-timestamp? ( timestamp -- ? )
-    clone instant >>gmt-offset
-    dup <zero> time- <zero> time+ = ;
-
 : unix-1970 ( -- timestamp )
     1970 <year-gmt> ; inline
 
@@ -371,9 +379,6 @@ GENERIC: days-in-year ( obj -- n )
 M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
 M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 
-: (days-in-month) ( year month -- n )
-    dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
-
 : days-in-month ( timestamp -- n )
     >date< drop (days-in-month) ;
 
@@ -507,16 +512,11 @@ M: timestamp december clone 12 >>month ;
 : o'clock ( timestamp n -- new-timestamp )
     [ midnight ] dip >>hour ;
 
-ERROR: twelve-hour-expected n ;
-
-: check-twelve-hour ( n -- n )
-    dup 0 12 between? [ twelve-hour-expected ] unless ;
-
 : am ( timestamp n -- new-timestamp )
-    check-twelve-hour o'clock ;
+    0 12 [a,b] check-interval o'clock ;
 
 : pm ( timestamp n -- new-timestamp )
-    check-twelve-hour 12 + o'clock ;
+    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 ;