;; THIS FILE IS GENERATED

(module rfc3339 mzscheme
(require (lib "9.ss" "srfi"))

;;; @Package     rfc3339.scm
;;; @Subtitle    RFC3339 Date and Time Format in Scheme
;;; @HomePage    http://www.neilvandyke.org/rfc3339-scm/
;;; @Author      Neil W. Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.2
;;; @Date        2005-12-05

;; $Id: rfc3339.scm,v 1.72 2005/12/05 11:28:37 neil Exp $

;;; @legal
;;; Copyright @copyright{} 2005 Neil W. Van Dyke.  This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at your option) any
;;; later version.  This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/copyleft/lesser.html} for details.  For
;;; other license options and consulting, contact the author.
;;; @end legal

;; (require (lib "9.ss" "srfi"))

(define-syntax %rfc3339:testeez
  (syntax-rules () ((_ x ...)
                    ;; (testeez x ...)
                    (error "Tests disabled.")
                    )))

(define %rfc3339:regexp          regexp)
(define %rfc3339:regexp-match    regexp-match)
(define %rfc3339:regexp-cc-minus "-")

;; TODO: Wait for Pregexp workaround or fix for alternations of clusters, which
;; have a known bug in Pregexp 1e9:
;;
;; (pregexp-match "(b)"     "b")  ==>  ("b" "b")
;; (pregexp-match "(a)|(b)" "b")  ==>  ("b" "b")
;;
;; (require (lib "pregexp.ss"))
;; (define %rfc3339:regexp          pregexp)
;; (define %rfc3339:regexp-match    pregexp-match)
;; (define %rfc3339:regexp-cc-minus "\\-")

;;; @section Introduction

;;; The @code{rfc3339.scm} package implements parsing, formatting, and simple
;;; validation of @uref{ftp://ftp.rfc-editor.org/in-notes/rfc3339.txt, RFC3339}
;;; date and time format, which is a subset of
;;; @uref{http://www.iso.ch/iso/en/prods-services/popstds/datesandtime.html,
;;; ISO 8601}, intended for use in Internet protocols.
;;;
;;; Note that full Scheme support of ISO 8601 is a very different project of
;;; the author, and not at all the intention of @code{rfc3339.scm}.
;;;
;;; @code{rfc3339.scm} requires R5RS, SRFI-6, SRFI-9, and two particular
;;; regular expression functions.  Note that the regular expression functions
;;; in @uref{http://www.ccs.neu.edu/home/dorai/pregexp/pregexp.html, Pregexp
;;; 1e9} will not work, but are expected to work in subsequent versions of
;;; Pregexp.  Thus far, @code{rfc3339.scm} has only been tested under PLT
;;; MzScheme.

;;; @section Record Type

;;; @code{rfc3339-record} is an abstract data type for the information in an
;;; RFC3339 format time and date.  (``@code{rfc3339-string}'' is used in
;;; identifiers to denote the RFC3339 format as a Scheme string.)

(define-record-type rfc3339-record
  (make-rfc3339-record year month mday hour minute second secfrac offsetmin)
  rfc3339-record?
  (year      rfc3339-record:year      rfc3339-record:set-year!)
  (month     rfc3339-record:month     rfc3339-record:set-month!)
  (mday      rfc3339-record:mday      rfc3339-record:set-mday!)
  (hour      rfc3339-record:hour      rfc3339-record:set-hour!)
  (minute    rfc3339-record:minute    rfc3339-record:set-minute!)
  (second    rfc3339-record:second    rfc3339-record:set-second!)
  (secfrac   rfc3339-record:secfrac   rfc3339-record:set-secfrac!)
  (offsetmin rfc3339-record:offsetmin rfc3339-record:set-offsetmin!))

;;; @defproc make-rfc3339-record year month mday hour minute second secfrac offsetmin
;;;
;;; Construct an @code{rfc3339-record} with the given field values.  Each of
;;; @var{year}, @var{month}, @var{mday}, @var{hour}, @var{minute}, and
;;; @var{second} is @code{#f} or a nonnegative integer.  @var{secfrac} is
;;; @code{#f} or a real number that is greater than or equal to 0.0 and less
;;; than 1.0.  @var{offsetmin} is @code{#f} or a nonnegative integer.  Note
;;; that @var{offsetmin} represents both the hour and minute components of an
;;; RFC3339 string.

;;; @defproc rfc3339-record? x
;;;
;;; Predicate for @code{rfc3339-record}.

;;; @defproc  rfc3339-record:year      rec
;;; @defprocx rfc3339-record:month     rec
;;; @defprocx rfc3339-record:mday      rec
;;; @defprocx rfc3339-record:hour      rec
;;; @defprocx rfc3339-record:minute    rec
;;; @defprocx rfc3339-record:second    rec
;;; @defprocx rfc3339-record:secfrac   rec
;;; @defprocx rfc3339-record:offsetmin rec
;;;
;;; Get the respective field value of @code{rfc3339-record} @var{rec}.

;;; @defproc  rfc3339-record:set-year!      rec val
;;; @defprocx rfc3339-record:set-month!     rec val
;;; @defprocx rfc3339-record:set-mday!      rec val
;;; @defprocx rfc3339-record:set-hour!      rec val
;;; @defprocx rfc3339-record:set-minute!    rec val
;;; @defprocx rfc3339-record:set-second!    rec val
;;; @defprocx rfc3339-record:set-secfrac!   rec val
;;; @defprocx rfc3339-record:set-offsetmin! rec val
;;;
;;; Set the respective field value of @code{rfc3339-record} @var{rec} to
;;; @var{val}.

;;; @defproc rfc3339-record->list rec
;;;
;;; Yields a list of the @code{rfc3339-record} @var{rec} fields, corresponding
;;; to the arguments of the @code{make-rfc3339-record} procedure.
;;;
;;; @lisp
;;; (rfc3339-record->list
;;;  (make-rfc3339-record 1985 4 12 23 20 50 0.52 0))
;;; @result{} (1985 4 12 23 20 50 0.52 0)
;;; @end lisp

(define (rfc3339-record->list rec)
  (list (rfc3339-record:year      rec)
        (rfc3339-record:month     rec)
        (rfc3339-record:mday      rec)
        (rfc3339-record:hour      rec)
        (rfc3339-record:minute    rec)
        (rfc3339-record:second    rec)
        (rfc3339-record:secfrac   rec)
        (rfc3339-record:offsetmin rec)))

;;; @section Parsing

;;; The parsing procedures are for constructing a @code{rfc3339-record}s,
;;; lists, and vectors from RFC3339 strings.  The underlying parser can also
;;; apply a user-supplied closure directly.

;;; @defproc parse-rfc3339-string str constructor
;;;
;;; Parses RFC3339 string @var{str} and applies procedure @var{constructor}
;;; with the parsed values.  The arguments of @var{constructor} are the same
;;; as those of @code{make-rfc3339-record}.

(define parse-rfc3339-string
  (let ((rx (%rfc3339:regexp
             (string-append
              "^ *"
              "(?:([0-9]+)(?:-([0-9]+)(?:-([0-9]+))?)?)?"
              "([Tt]| +)?"
              "(?:([0-9]+)(?::([0-9]+)(?::([0-9]+)(?:(.[0-9]+))?)?)?)?"
              ;;" *"
              "(?:([Zz])|(?:(["
              %rfc3339:regexp-cc-minus ; for pregexp 1e9
              "+])(?:([0-9]+)?(?::([0-9]+)?))))?"
              " *$"))))
    (lambda (str constructor)
      (cond ((%rfc3339:regexp-match rx str)
             =>
             (lambda (result)
               (apply (lambda (whole dy dm dd t th tm ts tf z os oh om)
                        ;; Note: Very gross, but we want to use the limited
                        ;; (and hopefully fast native) regexp.
                        (if (and dy (not dm) (not t) th)
                            (begin (set! th (string-append dy th))
                                   (set! dy #f)))
                        (constructor
                         (if dy (string->number dy) #f)
                         (if dm (string->number dm) #f)
                         (if dd (string->number dd) #f)
                         (if th (string->number th) #f)
                         (if tm (string->number tm) #f)
                         (if ts (string->number ts) #f)
                         (if tf (string->number tf) #f)
                         (cond (z 0)
                               ((or oh om)
                                (* (if (equal? os "-") -1 1)
                                   (+ (* (if oh (string->number oh) 0) 60)
                                      (if om (string->number om) 0))))
                               (else #f))))
                      result)))
            (else #f)))))

;;; @defproc  string->rfc3339-record str
;;;
;;; Yields an @code{rfc3339-record} from RFC3339 string @var{str}.

(define (string->rfc3339-record str)
  (parse-rfc3339-string str make-rfc3339-record))

;;; @defproc  rfc3339-string->list   str
;;; @defprocx rfc3339-string->vector str
;;;
;;; Yields a list or vector (respectively) from the parsed values of RFC3339
;;; string @var{str}.  The list and vector elements correspond to the arguments
;;; of @code{make-rfc3339-record}.
;;;
;;; @lisp
;;; (rfc3339-string->list   "1985-04-12T23:20:69.52+5:0")
;;; @result{}  (1985 4 12 23 20 69 0.52 300)
;;; (rfc3339-string->vector "1985-04-12T23:20:69.52+5:0")
;;; @result{} #(1985 4 12 23 20 69 0.52 300)
;;; @end lisp

(define (rfc3339-string->list   str) (parse-rfc3339-string str list))
(define (rfc3339-string->vector str) (parse-rfc3339-string str vector))

;;; @section Formatting

;;; An RFC3339 string format can be obtained from an @code{rfc3339-record}.

(define %rfc3339:write-zpad
  (let ((zeroes '#("" "0" "00" "000" "0000")))
    (lambda (num width port)
      (if num
          (let ((pad (cond ((< num 10)   (- width 1))
                           ((< num 100)  (- width 2))
                           ((< num 1000) (- width 3))
                           (else         0))))
            (if (> pad 0)
                (display (vector-ref zeroes pad) port))
            (display num port))
          (display (vector-ref zeroes width) port)))))

(define (%rfc3339:write-date port dy dm dd)
  (%rfc3339:write-zpad dy  4 port)
  (write-char                  #\-   port)
  (%rfc3339:write-zpad dm  2 port)
  (write-char                  #\-   port)
  (%rfc3339:write-zpad dd  2 port))

(define (%rfc3339:write-time port th tm ts tf)
  (%rfc3339:write-zpad th  2 port)
  (write-char                  #\:   port)
  (%rfc3339:write-zpad tm  2 port)
  (write-char                  #\:   port)
  (%rfc3339:write-zpad ts  2 port)
  (if tf
      (if (zero? tf)
          (display ".0" port)
          (let ((str (number->string tf)))
            (if (equal? str "0.0")
                (display ".0" port)
                (display (substring str 1 (string-length str)) port))))))

(define (%rfc3339:write-offset port om)
  (case om
    ((0)  (write-char #\Z port))
    ((#f) (if #f #f))
    (else (let ((om (if (< om 0)
                        (begin (write-char #\- port)
                               (- om))
                        (begin (write-char #\+ port)
                               om))))
            (display (quotient om 60) port)
            (write-char #\: port)
            (%rfc3339:write-zpad (remainder om 60) 2 port)))))

(define (%rfc3339:write-full port dy dm dd th tm ts tf om)
  (let ((d? (or dy dm dd))
        (t? (or th tm ts tf)))
    (if d?
        (%rfc3339:write-date port dy dm dd))
    (if (and d? t?)
        (write-char #\T port))
    (if t?
        (%rfc3339:write-time port th tm ts tf))
    (if om
        (%rfc3339:write-offset port om))))

;;; @defproc write-rfc3339 rec port
;;;
;;; Write an RFC3339 string format of @code{rfc3339-record} @var{rec} to
;;; output port @var{port}.

(define (write-rfc3339-record rec port)
  ;; TODO: Maybe lose this "apply".
  (apply %rfc3339:write-full port (rfc3339-record->list rec)))

;;; @defproc rfc3339-record->string rec
;;;
;;; Yield an RFC3339 string format of @code{rfc3339-record} @var{rec} as a
;;; Scheme string.

(define (rfc3339-record->string rec)
  (let ((os (open-output-string)))
    (write-rfc3339-record rec os)
    (let ((str (get-output-string os)))
      (close-output-port os)
      str)))

;;; @section Validation

;;; A few procedures are provided for validating @code{rfc3339-record}s.

(define-syntax %rfc3339:field-check
  (syntax-rules ()
    ((_ ?explain?-var ?var ?valid-expr)
     (cond ((not ?var)  (if ?explain?-var
                            (list 'missing (quote ?var))
                            #t))
           (?valid-expr #f)
           (else        (if ?explain?-var
                            (list 'invalid
                                  (quote ?var)
                                  ?var
                                  (quote ?valid-expr))
                            #t))))))

(define (%rfc3339:leap-year? year)
  (and (zero? (modulo year 4))
       (if (zero? (modulo year 100))
           (zero? (modulo year 400))
           #t)))

(define (%rfc3339:month-days year month)
  (case month
    ((1 3 5 7 8 10 12) 31)
    ((4 6 9 11)        30)
    ((2)               (if (%rfc3339:leap-year? year) 29 28))
    (else              #f)))

;;; @defproc  check-rfc3339-record-date   rec explain?
;;; @defprocx check-rfc3339-record-time   rec explain?
;;; @defprocx check-rfc3339-record-offset rec explain?
;;;
;;; Check the respective component of @code{rfc3339-record} @var{rec} for
;;; completeness and correctness, yielding @code{#f} iff no problems were
;;; detected.  If @var{explain?} is true, then true values of these procedures
;;; are lists that ``explain'' the error detected.  For example:
;;;
;;; @lisp
;;; (check-rfc3339-record-date
;;;  (string->rfc3339-record "1999-02")    #t)
;;; @result{} (missing mday)
;;;
;;; (check-rfc3339-record-date
;;;  (string->rfc3339-record "1999-02-29") #t)
;;; @result{}
;;; (invalid mday 29 (and (integer? mday)
;;;                       (<= 1 mday (month-days year month))))
;;;
;;; (check-rfc3339-record-date
;;;  (string->rfc3339-record "2000-02-29") #t)
;;; @result{} #f
;;; @end lisp
;;;
;;; Leap years are calculated correctly.  Leap seconds (61st seconds in
;;; minutes) are tolerated in any date and time.

(define check-rfc3339-record-date
  (let ((month-days %rfc3339:month-days))
    (lambda (rec explain?)
      (let ((year  (rfc3339-record:year  rec))
            (month (rfc3339-record:month rec))
            (mday  (rfc3339-record:mday  rec)))
        (or (%rfc3339:field-check
             explain? year  (and (integer? year) (>= year 1)))
            (%rfc3339:field-check
             explain? month (and (integer? month) (<= 1 month 12)))
            (%rfc3339:field-check
             explain? mday  (and (integer? mday)
                                 (<= 1 mday (month-days year month)))))))))

(define (check-rfc3339-record-time rec explain?)
  (let ((hour    (rfc3339-record:hour    rec))
        (minute  (rfc3339-record:minute  rec))
        (second  (rfc3339-record:second  rec))
        (secfrac (rfc3339-record:secfrac rec)))
    (or (%rfc3339:field-check
         explain? hour    (and (integer? hour)   (<= 0 hour   23)))
        (%rfc3339:field-check
         explain? minute  (and (integer? minute) (<= 0 minute 59)))
        (%rfc3339:field-check
         explain? second  (and (integer? second) (<= 0 second 60)))
        (%rfc3339:field-check
         explain? secfrac (and (real? secfrac)
                               (<= 0.0 secfrac)
                               (< secfrac 1.0))))))

(define (check-rfc3339-record-offset rec explain?)
  (let ((offsetmin (rfc3339-record:offsetmin rec)))
    (%rfc3339:field-check explain?
                          offsetmin
                          (integer? offsetmin))))

;;; @defproc check-rfc3339-record-full rec explain?
;;;
;;; Checks all three components.  See @code{check-rfc3339-record-date} et al.

(define (check-rfc3339-record-full rec explain?)
  (or (check-rfc3339-record-date   rec explain?)
      (check-rfc3339-record-time   rec explain?)
      (check-rfc3339-record-offset rec explain?)))

;;; @defproc valid-full-rfc3339-record? rec
;;;
;;; Yields a true value iff @code{check-rfc3339-record-full} yields a false
;;; value.

(define (valid-full-rfc3339-record? rec)
  (not (check-rfc3339-record-full rec #f)))

;;; @section SRFI-19 Interoperability

;;; @code{rfc3339.scm} has no dependency on SRFI-19, but a procedure is
;;; provided for constructing a SRFI-19 @code{date}.

;;; @defproc rfc3339-string->srfi19-date/constructor str make-date
;;;
;;; Contruct a SRFI-19 @code{date} from an RFC3339 string, where @var{str} is
;;; the string, and @var{make-date} is the SRFI-19 @code{date} constructor.
;;; Applications using SRFI-19 may wish to define an
;;; @code{rfc3339-string->date} procedure:
;;;
;;; @lisp
;;; (define (rfc3339-string->date str)
;;;   (rfc3339-string->srfi19-date/constructor str make-date))
;;; @end lisp

(define (rfc3339-string->srfi19-date/constructor str make-date)
  (parse-rfc3339-string
   str
   (lambda (dy dm dd th tm ts tf om)
     (make-date (if tf (inexact->exact (truncate (* 100 tf))) 0) ; nanosecond
                (or ts 0)               ; second
                (or tm 0)               ; minute
                (or th 0)               ; hour
                (or dd 0)               ; day
                (or dm 0)               ; month
                (or dy 0)               ; year
                (if om (* 60 om) 0)     ; zone-offset
                ))))

;; TODO: rfc3339-record->srfi19-date/constructor

;;; @section Tests

;;; The @code{rfc3339.scm} test suite can be enabled by editing the source code
;;; file and loading @uref{http://www.neilvandyke.org/testeez/, Testeez}.

(define (%rfc3339:test)
  (%rfc3339:testeez
   "rfc3339.scm"

   ;;

   (test/equal "leap years"
               (map %rfc3339:leap-year? '(1600 1984 1996 2000 2400))
               '(#t #t #t #t #t))

   (test/equal "non-leap years"
               (map %rfc3339:leap-year? '(1700 1800 1899 1900 2100))
               '(#f #f #f #f #f))

   ;;

   (test/equal ""
               (rfc3339-string->list "1985-04-12T23:20:50.52Z")
               '(1985 4 12 23 20 50 0.52 0))

   (test/equal ""
               (rfc3339-string->list "1985-04-12T23:20:50.52")
               '(1985 4 12 23 20 50 0.52 #f))

   (test/equal ""
               (rfc3339-string->list "1985-04-12T23:20:50")
               '(1985 4 12 23 20 50 #f #f))

   (test/equal ""
               (rfc3339-string->list "1985-04-12T23:20")
               '(1985 4 12 23 20 #f #f #f))

   (test/equal ""
               (rfc3339-string->list "1985-04-12T23")
               '(1985 4 12 23 #f #f #f #f))

   (test/equal ""
               (rfc3339-string->list "1985-04-12T")
               '(1985 4 12 #f #f #f #f #f))

   (test/equal ""
               (rfc3339-string->list "1985-04-12")
               '(1985 4 12 #f #f #f #f #f))

   (test/equal ""
               (rfc3339-string->list "1985-04")
               '(1985 4 #f #f #f #f #f #f))

   (test/equal ""
               (rfc3339-string->list "1985")
               '(1985 #f #f #f #f #f #f #f))

   ;;

   (test/equal
    ""
    (rfc3339-record->string (string->rfc3339-record "1111-11-11T11:11:11.123"))
    "1111-11-11T11:11:11.123")

   (test/equal
    ""
    (rfc3339-record->string (string->rfc3339-record "1111-11-11T11:11:11"))
    "1111-11-11T11:11:11")

   (test/equal
    ""
    (rfc3339-record->string (string->rfc3339-record "1111-11-11T11:11:11.0"))
    "1111-11-11T11:11:11.0")

   ;;

   (test/equal ""
               (rfc3339-record->string (string->rfc3339-record "1-1-1"))
               "0001-01-01")

   (test/equal ""
               (rfc3339-record->string (string->rfc3339-record "1:1:1"))
               "01:01:01")

   ;;

   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "T+0:0")) "Z")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "+0:0"))  "Z")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "T-0:0")) "Z")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "-0:0"))  "Z")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "TZ"))    "Z")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "Z"))     "Z")

   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "+0:01"))   "+0:01")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "+000:01")) "+0:01")

   ;;

   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "T12:34")) "12:34:00")
   (test/equal
    "" (rfc3339-record->string (string->rfc3339-record "12:34"))  "12:34:00")

   ))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.2 --- 2005-12-05
;;; Release for PLT 299/3xx.  Changed portability note in light of Pregexp
;;; post-1e9 bug fix.  Minor documentation changes.
;;;
;;; @item Version 0.1 --- 2005-01-30
;;; Initial release.
;;;
;;; @end table

(provide (all-defined)))