On 2013-01-11 23:08:30 -0600, Robby Findler wrote: > How about calling the new struct "lax-date" or something like that, using > the word you're using below -- I'm not tied to that word, but something > that explains more why it is there seems good.
That sounds good. > Also, I think the documentation needs to be updated to explain the > relationship between the racket/date structs and the srfi-19 date structs. > I'm less clear about the other laxness. One other possible thing to > consider is that srfi:make-date could do all the same checking that date* > does, but if any of it fails (perhaps catch the exn) it creates a lax > date. That seems safest. I thought about this, and the only objection that I had was that a contract error could now silently turn into a valid old srfi/19 style date object. Then again, this would only happen with the constructor exported from srfi/19, so maybe it's not a big deal. In any case, see attached patch for implementation (just catches the exception). Cheers, Asumu
>From 77287c4e948dabdb7c761af1b6f56d82cbc36adc Mon Sep 17 00:00:00 2001 From: Asumu Takikawa <as...@ccs.neu.edu> Date: Fri, 11 Jan 2013 21:06:01 -0500 Subject: [PATCH] Make srfi/19 compatible with date* structs --- collects/srfi/19/time.rkt | 226 ++++++++++++++++++++++---------------- collects/tests/srfi/19/tests.rkt | 8 ++ 2 files changed, 138 insertions(+), 96 deletions(-) diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt index bac5a33..70617c7 100644 --- a/collects/srfi/19/time.rkt +++ b/collects/srfi/19/time.rkt @@ -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)) - -(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)) +;; 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-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/tests/srfi/19/tests.rkt b/collects/tests/srfi/19/tests.rkt index cdd3b63..2981ed9 100644 --- a/collects/tests/srfi/19/tests.rkt +++ b/collects/tests/srfi/19/tests.rkt @@ -221,6 +221,14 @@ (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))) + + (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))) ;; nanosecnds off by a factor of 100... (test-case "nanosecond order-of-magnitude" -- 1.7.10.4
_________________________ Racket Developers list: http://lists.racket-lang.org/dev