Changeset 16010 in project


Ignore:
Timestamp:
09/21/09 10:35:36 (10 years ago)
Author:
Ivan Raikov
Message:

introduced a timestamp record type in internet-timestamp

Location:
release/4/internet-timestamp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/internet-timestamp/internet-timestamp.scm

    r15985 r16010  
    3939(module internet-timestamp
    4040
    41         (parser)
    42 
    43         (import scheme chicken data-structures srfi-1 srfi-14)
     41        (parser ts? ts-date ts-time ts-offset ts->list)
     42
     43        (import scheme chicken data-structures extras srfi-1 )
     44        (import (only srfi-13 string-trim string-concatenate))
    4445
    4546        (require-library abnf abnf-consumers)
     
    6364(define consumed-numbers
    6465  (abnf:consumed-objects number?))
    65 (define consumed-numbers->list
    66   (abnf:consumed-objects-lift consumed-numbers))
    67 
    68 ;; shortcut for (bind (consumed-numbers->list ...) (longest ... ))
    69 (define-syntax bind-consumed-numbers->list
    70   (syntax-rules ()
    71     ((_ l p)    (abnf:bind (consumed-numbers->list l)  (abnf:longest p)))
    72     ((_ p)      (abnf:bind (consumed-numbers->list)    (abnf:longest p)))
    73     ))
     66(define consumed-numbers->list
     67  (abnf:consumed-objects-lift
     68   consumed-numbers))
    7469
    7570(define consumed-objects-lift-any
    7671  (abnf:consumed-objects-lift
    7772   (abnf:consumed-objects identity)))
     73
     74
     75;; timestamp datatype
     76(define-record-type ts (make-ts date time offset)
     77  ts?  (date ts-date )
     78  (time ts-time )
     79  (offset ts-offset )
     80  )
     81
     82;; convert a number to a string with leading zeros
     83(define (number->lzstring n)
     84  (lambda (x)
     85    (or (and (number? x)
     86             (let loop ((d (string->list (number->string x))))
     87               (if (>= (length d) n) (list->string d)
     88                   (loop (cons #\0 d)))))
     89        x)))
     90           
     91           
     92
     93(define-record-printer (ts x out)
     94  (let ((number->lzstring2 (number->lzstring 2))
     95        (number->lzstring4 (number->lzstring 4)))
     96    (fprintf out "~AT~A~A"
     97             (let ((date-list (vector->list (ts-date x))))
     98               (apply sprintf (cons* "~A-~A-~A"
     99                                     (number->lzstring4 (car date-list))
     100                                     (map number->lzstring2 (cdr date-list)))))
     101             (string-concatenate
     102              (cons
     103               (apply sprintf
     104                      (cons "~A:~A:~A"
     105                            (map number->lzstring2 (vector->list (ts-time x)))))
     106               (cond ((vector-ref (ts-time x) 3) =>
     107                      (lambda (frac)
     108                        (list (string-trim (number->string frac) #\0))))
     109                     (else (list)))))
     110             (case (vector-ref (ts-offset x) 0)
     111               ((Z)  "Z")
     112               (else (apply sprintf
     113                            (cons "~A~A:~A"
     114                                  (map number->lzstring2 (vector->list (ts-offset x)))))))
     115             )))
     116               
     117(define (ts->list x)
     118  (and (ts? x)
     119       (let ((date (ts-date x))
     120             (time (ts-time x))
     121             (offset (ts-offset x)))
     122       `((date ,(vector->list date))
     123         (time ,(filter identity (vector->list time)))
     124         (offset ,(filter identity (vector->list offset)))))))
     125 
     126
     127(define (make-date year month day)
     128  (make-ts (vector year month day) #f #f))
     129
     130(define (make-partial-time hr min sec . rest)
     131  (let-optionals rest ((frac #f))
     132    (make-ts #f (vector hr min sec frac)
     133             #f)))
     134
     135(define (make-offset sign . rest)
     136  (let-optionals rest ((hr #f) (min #f))
     137    (make-ts #f #f (vector sign hr min))))
     138 
     139(define (make-full-time time offset)
     140  (let ((time (ts-time time))
     141        (offset (ts-offset offset)))
     142    (make-ts #f time offset)))
     143 
     144(define (make-date-time date time )
     145  (let ((time (ts-time time))
     146        (offset (ts-offset time))
     147        (date  (ts-date date)))
     148    (make-ts date time offset)))
    78149
    79150(define (number-n n)
     
    105176  (abnf:bind
    106177   (consumed-objects-lift-any
    107     (lambda (x) `( ,(first x) ,(second x) ,(third x))))
     178    (lambda (x) (make-offset (first x) (second x) (third x))))
    108179   (abnf:concatenation
    109180    (abnf:bind-consumed->symbol
     
    114185(define time-offset
    115186  (abnf:alternatives
    116    (abnf:bind (lambda (x) '((Z))) (abnf:char #\Z))
     187   (abnf:bind (lambda (x) (list (make-offset 'Z))) (abnf:char #\Z))
    117188   time-numoffset))
    118189
    119190(define partial-time
    120   (bind-consumed-numbers->list
     191  (abnf:bind
     192   (consumed-numbers->list (lambda (x) (apply make-partial-time x)))
    121193    (abnf:concatenation
    122194     time-hour (abnf:drop-consumed (abnf:char #\:) )
     
    125197     (abnf:optional-sequence time-secfrac))))
    126198
     199(define full-time
     200  (abnf:bind
     201   (consumed-objects-lift-any
     202    (lambda (x) (make-full-time (first x) (second x))))
     203   (abnf:concatenation
     204    partial-time
     205    time-offset)))
     206
    127207(define full-date
    128    (abnf:bind-consumed-pairs->list 'date
    129     (bind-consumed-numbers->list
    130      (abnf:concatenation
    131       date-fullyear
    132       (abnf:drop-consumed (abnf:char #\-)) date-month
    133       (abnf:drop-consumed (abnf:char #\-)) date-mday))))
    134 
    135 (define full-time
    136   (abnf:concatenation
    137    (abnf:bind-consumed-pairs->list 'time
    138      partial-time)
    139    (abnf:bind-consumed-pairs->list 'offset
    140      time-offset)))
     208  (abnf:bind
     209   (consumed-numbers->list (lambda (x) (apply make-date x)))
     210   (abnf:concatenation
     211    date-fullyear
     212    (abnf:drop-consumed (abnf:char #\-)) date-month
     213    (abnf:drop-consumed (abnf:char #\-)) date-mday)))
    141214
    142215(define date-time
    143   (abnf:concatenation
    144    full-date (abnf:drop-consumed (abnf:char #\T))
    145    full-time))
     216  (abnf:bind
     217   (consumed-objects-lift-any
     218    (lambda (x) (make-date-time (first x) (second x) )))
     219   (abnf:concatenation
     220    full-date (abnf:drop-consumed (abnf:char #\T))
     221    full-time)))
     222
     223
    146224
    147225
     
    159237    (lambda (s)
    160238      (let ((r (p (check s) `((() ,(->char-list s))))))
    161         (and (pair? r) (reverse (caar r)))))))
     239        (and (pair? r) (car (caar r)))))))
    162240
    163241)
  • release/4/internet-timestamp/tests/run.scm

    r15984 r16010  
    55            (test
    66             `((date (1985 4 12)) (time (23 20 50 0.52)) (offset (Z)))
    7              (parser "1985-04-12T23:20:50.52Z"))
     7             (ts->list (parser "1985-04-12T23:20:50.52Z")))
    88           
    99            (test
    1010             `((date (1996 12 19)) (time (16 39 57)) (offset (- 8 0)))
    11              (parser "1996-12-19T16:39:57-08:00"))
     11             (ts->list (parser "1996-12-19T16:39:57-08:00")))
    1212
    1313            (test
    1414             `((date (1990 12 31)) (time (23 59 60)) (offset (Z)))
    15              (parser "1990-12-31T23:59:60Z"))
     15             (ts->list (parser "1990-12-31T23:59:60Z")))
    1616
    1717            (test
    1818             `((date (1990 12 31)) (time (15 59 60)) (offset (- 8 0)))
    19              (parser "1990-12-31T15:59:60-08:00"))
     19             (ts->list (parser "1990-12-31T15:59:60-08:00")))
    2020
    2121            (test
    2222             `((date (1937 01 01)) (time (12 00 27 0.87)) (offset (+ 0 20)))
    23              (parser "1937-01-01T12:00:27.87+00:20"))
     23             (ts->list (parser "1937-01-01T12:00:27.87+00:20")))
    2424            )
Note: See TracChangeset for help on using the changeset viewer.