On 2013-01-11 20:58:02 -0600, Robby Findler wrote:
> I think backwards compatibility here is probably more important than it
> producing a racket date. Is there some reason not to think so? I believe
> this library gets used a lot.
Ok, attached is a second attempt that will use a different struct type
if `string->date` gets passed a format string that's missing day, month,
or year. The `make-date` function will also construct one of these lax
types if the day, month, or year fields is #t. These dates should work
normally, except that racket/date won't like them.
This doesn't attempt to preserve other laxness in srfi/19. For example,
`make-date` previously would not do any error checking of its fields (so
it won't error until an operation is used which cares about that field).
It should also support deserialization like Ryan pointed out.
Cheers,
Asumu
>From 8855d390571eabbb9082516d2486301531c36dae 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 | 229 ++++++++++++++++++++++----------------
collects/tests/srfi/19/tests.rkt | 8 ++
2 files changed, 141 insertions(+), 96 deletions(-)
diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt
index bac5a33..323d7d8 100644
--- a/collects/srfi/19/time.rkt
+++ b/collects/srfi/19/time.rkt
@@ -608,40 +608,46 @@
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)
+ (if (or (eq? day #t) (eq? month #t) (eq? year #t))
+ (srfi-19-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
+;; In particular, allows '#t' as day, month, year
+(struct srfi-19-date (nanosecond second minute
+ hour day month
+ year zone-offset)
+ #:transparent)
+
+;; Convert srfi-19 date to date*
+(define (srfi-19-date->date* date)
+ (srfi:make-date (srfi-19-date-nanosecond date)
+ (srfi-19-date-second date)
+ (srfi-19-date-minute date)
+ (srfi-19-date-hour date)
+ (srfi-19-date-day date)
+ (srfi-19-date-month date)
+ (srfi-19-date-year date)
+ (srfi-19-date-zone-offset date)))
+
+;; Predicate for dates
+(define (srfi:date? d)
+ (or (srfi-19-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 +661,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 (srfi-19-date? d)
+ (srfi-19-accessor d)
+ (date-accessor d))))
+
+(define-date-accessor date-nanosecond srfi-19-date-nanosecond date*-nanosecond)
+(define-date-accessor srfi:date-second srfi-19-date-second date-second)
+(define-date-accessor srfi:date-minute srfi-19-date-minute date-minute)
+(define-date-accessor srfi:date-hour srfi-19-date-hour date-hour)
+(define-date-accessor srfi:date-day srfi-19-date-day date-day)
+(define-date-accessor srfi:date-month srfi-19-date-month date-month)
+(define-date-accessor srfi:date-year srfi-19-date-year date-year)
+(define-date-accessor date-zone-offset
+ srfi-19-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 +786,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 +1474,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 srfi-19-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 srfi-19-date object [month val])))
+ (list #\d char-numeric? ireader2
+ (lambda (val object)
+ (struct-copy srfi-19-date object [day val])))
+ (list #\e char-fail eireader2
+ (lambda (val object)
+ (struct-copy srfi-19-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 srfi-19-date object [month val])))
+ (list #\H char-numeric? ireader2
+ (lambda (val object)
+ (struct-copy srfi-19-date object [hour val])))
+ (list #\k char-fail eireader2
+ (lambda (val object)
+ (struct-copy srfi-19-date object [hour val])))
+ (list #\m char-numeric? ireader2
+ (lambda (val object)
+ (struct-copy srfi-19-date object [month val])))
+ (list #\M char-numeric? ireader2
+ (lambda (val object)
+ (struct-copy srfi-19-date object [minute val])))
+ (list #\N char-numeric? fireader9
+ (lambda (val object)
+ (struct-copy srfi-19-date object [nanosecond val])))
+ (list #\S char-numeric? ireader2
+ (lambda (val object)
+ (struct-copy srfi-19-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 srfi-19-date object
+ [year (tm:natural-year val)])))
+ (list #\Y char-numeric? ireader4
+ (lambda (val object)
+ (struct-copy srfi-19-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 srfi-19-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 srfi-19-date object
+ [year (tm:natural-year val)])))
)))
(define (tm:string->date date index format-string str-len port template-string)
@@ -1505,8 +1536,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 +1556,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 +1574,20 @@
(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 (srfi-19-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
+ (if (or (eq? (srfi-19-date-day newdate) #t)
+ (eq? (srfi-19-date-month newdate) #t)
+ (eq? (srfi-19-date-year newdate) #t))
+ newdate
+ (srfi-19-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
