;;;; srfi-19-literals.scm  -*- Scheme -*-

(declare (bound-to-procedure ##sys#register-record-printer))

(module srfi-19-literals

(;export
  date-literal-form
  time-literal-form
  read-date-literal
  write-date-literal)

(import scheme
	(chicken base)
	utf8
	(chicken type)
	(only (chicken condition) handle-exceptions)
	(only (chicken io) read-token)
	(only (chicken read-syntax) define-reader-ctor)
	(only (chicken format) format)
	(only (chicken read-syntax) define-reader-ctor)
	(only (chicken read-syntax) set-sharp-read-syntax!)
	(only utf8-srfi-13 string-index)
	(only srfi-19-io string->date format-date)
	srfi-19-tm)

;;;

(include-relative "srfi-19-common")

(include-relative "srfi-19-common.types")

(: date-literal-form (#!optional (or boolean symbol) -> (or false symbol)))
(: time-literal-form (#!optional (or boolean symbol) -> (or false symbol)))
(: read-date-literal (#!optional input-port -> list))
(: write-date-literal (date #!optional output-port -> (or true string)))

;;; Date Literal Syntax

(define-constant DATE-FORMAT-BRACKET "#<srfi-19#date ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S>")
(define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S)")

(define (date-record-printer-format-string)
  (case (date-literal-form)
    ((SRFI-10)
      DATE-FORMAT-SRFI-10 )
    (else
      DATE-FORMAT-BRACKET ) ) )

(define (date-record-formatter dat out)
  (format out (date-record-printer-format-string)
    (tm:date-nanosecond dat)
    (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
    (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
    (tm:date-zone-offset dat)
    (tm:date-zone-name dat) (tm:date-dst? dat)) )

;portions from C4 "date-literals.scm"

;;
;; 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.

;; Constants

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

(define-constant *date-iso-format* "~Y-~m-~dT~H:~M:~S~z")

(define-constant *date-literal-formats* `(
  ,*date-iso-format* "~Y-~m-~dT~H:~M:~S"
  "~Y-~m-~d"
  "~H:~M:~S~z" "~H:~M:~S"))

(define-constant *date-iso-literal-format* (string-append "#" "@" *date-iso-format*))

;; Internal helper procedures

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

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

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

;;;; Exported procedures

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

(define (write-date-literal date #!optional (port (current-output-port)))
  (format-date port *date-iso-literal-format* date) )

;;; Time Literal Syntax

(define-constant TIME-FORMAT-BRACKET "#<srfi-19#time ~S ~S ~S>")
(define-constant TIME-FORMAT-SRFI-10 "#,(srfi-19-time ~S ~S ~S)")

#; ;this is of dubious benefit
(define-constant TIME-FORMAT-LITERAL "##~S_~S_~S")

(define (bracket-time-literals)
  ;default output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer time) time-record-formatter) )
    (else
      (##sys#register-record-printer time time-record-formatter) ) ) )

(define (srfi-10-time-literals)
  ;srfi-10 output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer time) time-record-formatter) )
    (else
      (##sys#register-record-printer time time-record-formatter) ) )
  ;srfi-10 input handler
  (define-reader-ctor 'srfi-19-time tm:make-time) )

#; ;this is of dubious benefit
(define (time-literals)
  ;human legible output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer time) write-time-literal) )
    (else
      (##sys#register-record-printer time write-time-literal) ) )
  ;human legible input handler
  (set-sharp-read-syntax! #\# read-time-literal) )

(define (time-record-printer-format-string)
  (case (time-literal-form)
    ((srfi-10 SRFI-10)
      TIME-FORMAT-SRFI-10 )
    (else
      TIME-FORMAT-BRACKET ) ) )

(define (time-record-formatter tim out)
  (format out (time-record-printer-format-string)
    (tm:time-type tim)
    (tm:time-nanosecond tim)
    (tm:time-second tim)) )

(define (bracket-date-literals)
  ;default output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer date) date-record-formatter) )
    (else
      (##sys#register-record-printer date date-record-formatter) ) ) )

(define (srfi-10-date-literals)
  ;srfi-10 output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer date) date-record-formatter) )
    (else
      (##sys#register-record-printer date date-record-formatter) ) )
  ;srfi-10 input handler
  (define-reader-ctor 'srfi-19-date
    (lambda (ns sec min hr dy mn yr tzo tzn dstf)
      (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f))) )

(define (date-literals)
  ;human legible output form
  (cond-expand
    (chicken-5.3
      (set! (record-printer date) write-date-literal) )
    (else
      (##sys#register-record-printer date write-date-literal) ) )
  ;human legible input handler
  (set-sharp-read-syntax! #\@ read-date-literal) )

;;

(define date-literal-form
  (make-parameter #t
    (lambda (x)
      (cond
        ((not x)
          (bracket-date-literals)
          #f )
        ((or (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
          (srfi-10-date-literals)
          'SRFI-10 )
        ((or (eq? '|#@| x) (eq? #t x))
          (date-literals)
          '|#@|)
        (else
          (warning 'date-literal-form "invalid format" x)
          (date-literal-form) ) ) ) ) )

(define time-literal-form
  (make-parameter 'SRFI-10
    (lambda (x)
      (cond
        ((not x)
          (bracket-time-literals)
          #f )
        ((or (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
          (srfi-10-time-literals)
          'SRFI-10 )
        #; ;this is of dubious benefit
        ((or (eq? '|##| x) (eq? #t x))
          (time-literals)
          '|##|)
        (else
          (warning 'time-literal-form "invalid format" x)
          (time-literal-form) ) ) ) ) )

) ;module srfi-19-literals