;;;; A reader extension for SRFI-19 date/time literals.
;;
;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;; IN THE SOFTWARE.
(module date-literals
  (export read-date-literal write-date-literal)

  (import scheme chicken extras srfi-13)

  (require-extension srfi-19)

  ;;;; Constants

  (define-constant date-literal-charset "0123456789TZ:+-")

  (define-constant date-literal-formats
    '("~Y-~m-~dT~H:~M:~S~z" "~Y-~m-~dT~H:~M:~S" "~Y-~m-~d"
      "~H:~M:~S~z" "~H:~M:~S" ) )

  ;;;; Exported procedures

  (define (read-date-literal #!optional (port (current-input-port)))
    (let ((date (read-date-literal-string port)))
      (let loop ((formats date-literal-formats))
	(cond
	  ((null? formats) (error "invalid date/time literal" date))
	  ((parse-date-literal date (car formats)) => make-quoted-date)
	  (else (loop (cdr formats))) ) ) ) )

  (define (write-date-literal date #!optional (port (current-output-port)))
    (fprintf port "#@~A" (date->string date "~Y-~m-~dT~H:~M:~S~z")) )

  ;;;; Internal helper procedures

  (define (parse-date-literal date format)
    (handle-exceptions exn #f (string->date date format)) )

  (define (read-date-literal-string port)
    (read-token (lambda (c) (string-index date-literal-charset c)) port) )

  (define (make-quoted-date date)
    `(make-date ,(date-nanosecond date)
		,(date-second date) ,(date-minute date) ,(date-hour date)
		,(date-day date) ,(date-month date) ,(date-year date)
		,(date-zone-offset date) ) )

  ;;;; Initialization

  (define-inline (init-date-literals!)
    (define-record-printer date write-date-literal)
    (set-sharp-read-syntax! #\@ read-date-literal) )

  (init-date-literals!) )