From d406e2db5715ad272db5b78913afed1a4bb507b1 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 11 Jan 2013 21:06:01 -0500 Subject: [PATCH] Make srfi/19 compatible with date* structs - srfi/19 functions now produce and accept date*s - some functions produce lax-dates for backwards compat. --- collects/srfi/19/time.rkt | 226 ++++++++++++++++++------------- collects/srfi/srfi.scrbl | 31 ++++- collects/tests/srfi/19/tests.rkt | 31 ++++- 3 files changed, 187 insertions(+), 101 deletions(-) diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt index bac5a3388a..1ee4a051a3 100644 --- a/collects/srfi/19/time.rkt +++ b/collects/srfi/19/time.rkt @@ -78,7 +78,7 @@ time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration! ;; Date object and accessors ;; date structure is provided by core Racket, we just extended tu support miliseconds: - srfi:make-date srfi:date? + srfi:make-date srfi:date? lax-date? deserialize-info:tm:date-v0 date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month srfi:date-year date-zone-offset @@ -608,40 +608,47 @@ time-in) ;; -- Date Structures -(define-values (tm:date srfi:make-date srfi:date? tm:date-ref tm:date-set!) - (make-struct-type - 'tm:date #f 8 0 #f - (list (cons prop:serializable - (make-serialize-info - (lambda (d) - (vector (date-nanosecond d) - (srfi:date-second d) - (srfi:date-minute d) - (srfi:date-hour d) - (srfi:date-day d) - (srfi:date-month d) - (srfi:date-year d) - (date-zone-offset d))) - #'deserialize-info:tm:date-v0 - #f - (or (current-load-relative-directory) - (current-directory))))) - (make-inspector) #f null)) -(define deserialize-info:tm:date-v0 - (make-deserialize-info - srfi:make-date - (lambda () - (let ([d0 (srfi:make-date #f #f #f #f #f #f #f #f)]) - (values d0 (lambda (d1) - (tm:set-date-nanosecond! d1 (date-nanosecond d0)) - (tm:set-date-second! d1 (srfi:date-second d0)) - (tm:set-date-minute! d1 (srfi:date-minute d0)) - (tm:set-date-hour! d1 (srfi:date-hour d0)) - (tm:set-date-day! d1 (srfi:date-day d0)) - (tm:set-date-month! d1 (srfi:date-month d0)) - (tm:set-date-year! d1 (srfi:date-year d0)) - (tm:set-date-zone-offset! d1 (date-zone-offset d0)))))))) +;; These identifiers originally referred to a separate date type, +;; but they now use Racket's native date type +(define (srfi:make-date nanosecond second minute + hour day month + year zone-offset) + (with-handlers ([exn:fail:contract? + (lambda (e) + (lax-date nanosecond second minute hour + day month year zone-offset))]) + (date* second minute hour + day month year + ;; compute derived fields + (tm:week-day day month year) + (tm:year-day day month year) + #f + zone-offset + nanosecond + ""))) + +;; A struct type that emulates the old srfi/19 type +;; This is lax about its contents, unlike date* +(struct lax-date (nanosecond second minute + hour day month + year zone-offset) + #:transparent) + +;; Try to convert srfi-19 date to date* +(define (lax-date->date* date) + (srfi:make-date (lax-date-nanosecond date) + (lax-date-second date) + (lax-date-minute date) + (lax-date-hour date) + (lax-date-day date) + (lax-date-month date) + (lax-date-year date) + (lax-date-zone-offset date))) + +;; Predicate for dates +(define (srfi:date? d) + (or (lax-date? d) (date? d))) ;; Racket's date structure has the following: ;; * second : 0 to 61 (60 and 61 are for unusual leap-seconds) @@ -655,23 +662,29 @@ ;; * dst? : #t (daylight savings time) or #f ;; * time-zone-offset : the number of seconds east of GMT for this time zone (e.g., Pacific Standard Time is -28800), an exact integer 36 -(define (date-nanosecond d) (tm:date-ref d 0)) -(define (srfi:date-second d) (tm:date-ref d 1)) -(define (srfi:date-minute d) (tm:date-ref d 2)) -(define (srfi:date-hour d) (tm:date-ref d 3)) -(define (srfi:date-day d) (tm:date-ref d 4)) -(define (srfi:date-month d) (tm:date-ref d 5)) -(define (srfi:date-year d) (tm:date-ref d 6)) -(define (date-zone-offset d) (tm:date-ref d 7)) +;; These accessors work over either style of date +(define-syntax-rule (define-date-accessor accessor srfi-19-accessor date-accessor) + (define (accessor d) + (if (lax-date? d) + (srfi-19-accessor d) + (date-accessor d)))) -(define (tm:set-date-nanosecond! d ns) (tm:date-set! d 0 ns)) -(define (tm:set-date-second! d s) (tm:date-set! d 1 s)) -(define (tm:set-date-minute! d m) (tm:date-set! d 2 m)) -(define (tm:set-date-hour! d h) (tm:date-set! d 3 h)) -(define (tm:set-date-day! d day) (tm:date-set! d 4 day)) -(define (tm:set-date-month! d m) (tm:date-set! d 5 m)) -(define (tm:set-date-year! d y) (tm:date-set! d 6 y)) -(define (tm:set-date-zone-offset! d i) (tm:date-set! d 7 i)) +(define-date-accessor date-nanosecond lax-date-nanosecond date*-nanosecond) +(define-date-accessor srfi:date-second lax-date-second date-second) +(define-date-accessor srfi:date-minute lax-date-minute date-minute) +(define-date-accessor srfi:date-hour lax-date-hour date-hour) +(define-date-accessor srfi:date-day lax-date-day date-day) +(define-date-accessor srfi:date-month lax-date-month date-month) +(define-date-accessor srfi:date-year lax-date-year date-year) +(define-date-accessor date-zone-offset + lax-date-zone-offset date-time-zone-offset) + +;; Serialization support for old srfi-19 structs +(define deserialize-info:tm:date-v0 + (make-deserialize-info + srfi:make-date + (lambda () + (error 'deserialize-info:tm:date-v0 "cycles not allowed")))) ;; gives the julian day which starts at noon. (define (tm:encode-julian-day-number day month year) @@ -774,9 +787,17 @@ (define (time-tai->date time . tz-offset) (if (tm:tai-before-leap-second? (time-second time)) ;; if it's *right* before the leap, we need to pretend to subtract a second ... - (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc))) - (tm:set-date-second! d 60) - d) + (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) + (make-time time-duration 0 1)) + tz-offset time-utc))) + (srfi:make-date (date-nanosecond d) + 60 + (srfi:date-minute d) + (srfi:date-hour d) + (srfi:date-day d) + (srfi:date-month d) + (srfi:date-year d) + (date-zone-offset d))) (tm:time->date (time-tai->time-utc time) tz-offset time-utc))) (define (time-utc->date time . tz-offset) @@ -1454,46 +1475,57 @@ (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) (list #\b char-alphabetic? locale-reader-abbr-month (lambda (val object) - (tm:set-date-month! object val))) + (struct-copy lax-date object [month val]))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) - (tm:set-date-month! object val))) - (list #\d char-numeric? ireader2 (lambda (val object) - (tm:set-date-day! - object val))) - (list #\e char-fail eireader2 (lambda (val object) - (tm:set-date-day! object val))) + (struct-copy lax-date object [month val]))) + (list #\d char-numeric? ireader2 + (lambda (val object) + (struct-copy lax-date object [day val]))) + (list #\e char-fail eireader2 + (lambda (val object) + (struct-copy lax-date object [day val]))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) - (tm:set-date-month! object val))) - (list #\H char-numeric? ireader2 (lambda (val object) - (tm:set-date-hour! object val))) - (list #\k char-fail eireader2 (lambda (val object) - (tm:set-date-hour! object val))) - (list #\m char-numeric? ireader2 (lambda (val object) - (tm:set-date-month! object val))) - (list #\M char-numeric? ireader2 (lambda (val object) - (tm:set-date-minute! - object val))) - (list #\N char-numeric? fireader9 (lambda (val object) - (tm:set-date-nanosecond! object val))) - (list #\S char-numeric? ireader2 (lambda (val object) - (tm:set-date-second! object val))) + (struct-copy lax-date object [month val]))) + (list #\H char-numeric? ireader2 + (lambda (val object) + (struct-copy lax-date object [hour val]))) + (list #\k char-fail eireader2 + (lambda (val object) + (struct-copy lax-date object [hour val]))) + (list #\m char-numeric? ireader2 + (lambda (val object) + (struct-copy lax-date object [month val]))) + (list #\M char-numeric? ireader2 + (lambda (val object) + (struct-copy lax-date object [minute val]))) + (list #\N char-numeric? fireader9 + (lambda (val object) + (struct-copy lax-date object [nanosecond val]))) + (list #\S char-numeric? ireader2 + (lambda (val object) + (struct-copy lax-date object [second val]))) (list #\y char-fail eireader2 (lambda (val object) - (tm:set-date-year! object (tm:natural-year val)))) - (list #\Y char-numeric? ireader4 (lambda (val object) - (tm:set-date-year! object val))) + (struct-copy lax-date object + [year (tm:natural-year val)]))) + (list #\Y char-numeric? ireader4 + (lambda (val object) + (struct-copy lax-date object [year val]))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) - tm:zone-reader (lambda (val object) - (tm:set-date-zone-offset! object val))) + tm:zone-reader + (lambda (val object) + (struct-copy lax-date object [zone-offset val]))) ; PLT-specific extension for 2- or 4-digit years: - (list #\? char-numeric? ireader4 (lambda (val object) - (tm:set-date-year! object (tm:natural-year val)))) + (list #\? char-numeric? ireader4 + (lambda (val object) + (struct-copy lax-date object + [year (tm:natural-year val)]))) ))) (define (tm:string->date date index format-string str-len port template-string) @@ -1505,8 +1537,7 @@ (read-char port) (skip-until port skipper))))) (if (>= index str-len) - (begin - (values)) + date (let ( (current-char (string-ref format-string index)) ) (if (not (char=? current-char #\~)) (let ((port-char (read-char port))) @@ -1526,11 +1557,13 @@ (reader (caddr format-info)) (actor (cadddr format-info))) (skip-until port skipper) - (let ((val (reader port))) - (if (eof-object? val) - (tm:time-error 'string->date 'bad-date-format-string template-string) - (actor val date))) - (tm:string->date date (+ index 2) format-string str-len port template-string)))))))))) + (define new-date + (let ((val (reader port))) + (if (eof-object? val) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (actor val date)))) + (tm:string->date new-date (+ index 2) format-string str-len port template-string)))))))))) + (define (string->date input-string template-string) (define (tm:date-ok? date) @@ -1542,15 +1575,16 @@ (srfi:date-month date) (srfi:date-year date) (date-zone-offset date))) - (let ( (newdate (srfi:make-date 0 0 0 0 #t #t #t (tm:local-tz-offset))) ) - (tm:string->date newdate - 0 - template-string - (string-length template-string) - (open-input-string input-string) - template-string) + (let* ([initial (lax-date 0 0 0 0 #t #t #t (tm:local-tz-offset))] + [newdate (tm:string->date + initial + 0 + template-string + (string-length template-string) + (open-input-string input-string) + template-string)]) (if (tm:date-ok? newdate) - newdate + (lax-date->date* newdate) (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) diff --git a/collects/srfi/srfi.scrbl b/collects/srfi/srfi.scrbl index 26043809f5..619335a6a3 100644 --- a/collects/srfi/srfi.scrbl +++ b/collects/srfi/srfi.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc @(require scribble/manual + scribble/eval (for-syntax scheme/base) (for-label scheme/base racket/stream)) @@ -569,9 +570,33 @@ are also available from @racketmodname[scheme/foreign]. (string->date #f "string->date") )] -Take care NOT to confuse the internal date structure with the -Racket @racket[date]; they are not the same, and all procedures -from the SRFI library expect the former. +The date structure produced by this SRFI library is identical +to the one provided by @racketmodname[racket/base] in most cases +(see @racket[date]). + +For backwards compatibility, when an invalid date field value is +provided to the SRFI constructor, the constructor will produce a lax +date structure. A lax date structure is @emph{not} compatible with +functions from @racketmodname[racket/base] or +@racketmodname[racket/date]. SRFI functions such as +@racket[string->date] may return a lax date structure depending on the +format string. + +@(define srfi-19-eval (make-base-eval)) +@(srfi-19-eval '(require srfi/19)) + +@defproc[(lax-date? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[_v] is a lax date structure. Otherwise +returns @racket[#f]. + +@examples[#:eval srfi-19-eval + (lax-date? (make-date 0 19 10 10 14 "bogus" "bogus" 0)) + (lax-date? (make-date 0 19 10 10 14 1 2013 0)) + (lax-date? (string->date "10:21:00" "~H:~M:~S")) +]} + +@(close-eval srfi-19-eval) @; ---------------------------------------- diff --git a/collects/tests/srfi/19/tests.rkt b/collects/tests/srfi/19/tests.rkt index cdd3b6314c..c0e5bd6ece 100644 --- a/collects/tests/srfi/19/tests.rkt +++ b/collects/tests/srfi/19/tests.rkt @@ -7,7 +7,8 @@ ;; John Clements (nanoseconds off by x100) -- 2009-12-15 ;; Dave Gurnell (serializable dates and times) -- 2010-03-03 ;; Dave Gurnell (added ~x for string->date) -- 2010-03-10 -(require scheme/serialize +(require (only-in racket/date date->julian/scalinger) + scheme/serialize srfi/19/time) (require rackunit @@ -221,8 +222,34 @@ (check-equal? (deserialize (serialize (make-time time-utc 0 1))) (make-time time-utc 0 1)) (check-equal? (deserialize (serialize (make-time time-tai 2 3))) (make-time time-tai 2 3)) (check-equal? (deserialize (serialize (srfi:make-date 0 1 2 3 4 5 6 7))) (srfi:make-date 0 1 2 3 4 5 6 7))) + + ;; make sure that older srfi-19 structures still deserialize + (test-case "old deserialization" + (check-equal? (deserialize '((3) 1 (((lib "srfi/19/time.rkt") . deserialize-info:tm:date-v0)) + 0 () () (0 0 1 2 3 4 5 6 7))) + (srfi:make-date 0 1 2 3 4 5 6 7)) + (check-equal? (deserialize '((3) 1 (((lib "srfi/19/time.rkt") . deserialize-info:tm:date-v0)) + 0 () () (0 0 0 0 0 1 1 2004 0))) + (srfi:make-date 0 0 0 0 1 1 2004 0))) + + ;; test racket/date, lax-date functionality + (test-case "check date? and lax-date?" + (check-true (date? (srfi:make-date 0 4 5 0 1 10 2013 0))) + (check-true (date? (srfi:make-date 0 0 0 0 1 1 2004 0))) + (check-equal? (date->julian/scalinger (srfi:make-date 0 0 0 0 1 1 2004 0)) + 2453006) + (check-equal? (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) + 4906011/2) + (check-true (lax-date? (srfi:make-date 0 0 0 0 0 1 2004 0))) + (check-true (lax-date? (srfi:make-date 0 0 0 0 #t 1 2004 0))) + (check-true (lax-date? (srfi:make-date 0 0 0 0 #t #t 2004 0))) + (check-true (lax-date? (srfi:make-date 0 0 0 0 #t #t #t 0))) + (check-equal? (srfi:date-year (srfi:make-date 0 0 0 0 1 1 2004 #t)) + 2004) + (check-equal? (srfi:date-year (srfi:make-date 0 0 0 0 1 1 2004 0)) + 2004)) - ;; nanosecnds off by a factor of 100... + ;; nanoseconds off by a factor of 100... (test-case "nanosecond order-of-magnitude" ;; half a second should be within 1/10th of 10^9 / 2 nanoseconds (currently off by a factor of 100) (check-within (let ([t (date-nanosecond (current-date))])