;;;; 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
  ;DEPERECATED
  date-record-printer-format
  time-record-printer-format)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken module))
(import srfi-19-tm)
(import srfi-19-core)

(include "srfi-19-common")

;;; Date Literal Syntax

(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) ) ) ) ) )

;;

(import (only (chicken format) format))
(import (only (chicken read-syntax) define-reader-ctor))
(import (only (chicken read-syntax) set-sharp-read-syntax!))

(define (bracket-date-literals)
  ;default output form
  (##sys#register-record-printer *date-tag*
    (lambda (dat out) (date-record-formatter dat out))) )

(define (srfi-10-date-literals)
  ;srfi-10 output form
  (##sys#register-record-printer *date-tag*
    (lambda (dat out) (date-record-formatter dat out)))
  ;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
  (##sys#register-record-printer *date-tag*
    (lambda (dat out) (write-date-literal dat out)))
  ;human legible input handler
  (set-sharp-read-syntax! #\@ (cut read-date-literal <>)) )

;;

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

(import (only (chicken condition) handle-exceptions))
(import (only (chicken io) read-token))
(import (only srfi-13 string-index))
(import srfi-19-io)

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

(import (only (chicken read-syntax) define-reader-ctor))
(import (only (chicken format) format))

(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 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) ) ) ) ) )

(define (bracket-time-literals)
  ;default output form
  (##sys#register-record-printer *time-tag*
    (lambda (tim out) (time-record-formatter tim out))) )

(define (srfi-10-time-literals)
  ;srfi-10 output form
  (##sys#register-record-printer *time-tag*
    (lambda (tim out) (time-record-formatter tim out)))
  ;srfi-10 input handler
  (define-reader-ctor 'srfi-19-time
    (lambda (tt ns sec)
      (tm:make-time tt ns sec))) )

#; ;this is of dubious benefit
(define (time-literals)
  ;human legible output form
  (##sys#register-record-printer *time-tag*
    (lambda (tim out) (write-time-literal tim out)))
  ;human legible input handler
  (set-sharp-read-syntax! #\# (cut 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)) )

;;;

(: date-record-printer-format (deprecated date-literal-form))
(: time-record-printer-format (deprecated time-literal-form))

(define date-record-printer-format date-literal-form)
(define time-record-printer-format time-literal-form)

) ;module srfi-19-literals