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

;; Issues
;;
;; - cannot remove SRFI-10 ctor

(module srfi-19-literals

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

(import scheme
  utf8
  (chicken base)
  (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 irregex)
    irregex
    irregex-match irregex-match-data? irregex-match-num-submatches
    irregex-match-substring)
  (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!)
  (only utf8-srfi-13 string-index string-downcase)
  (only srfi-19-io string->date format-date)
  srfi-19-tm)

(cond-expand
  ((or chicken-5.0 chicken-5.1)
    (define (set-record-printer! tag proc)
      (##sys#register-record-printer tag proc) ) )
  (else) )

;;;

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

;;

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

;;; Date Literal Syntax

(define-constant DATE-FORMAT-BRACKET "#<~A ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S>")
(define-constant DATE-FORMAT-SRFI-10 "#,(~A ~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)
    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)
    (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

;all chars legal in any date-literal
(define-constant DATE-LITERAL-CHARS "0123456789TZ:+-")

(define-constant DATE-FORMAT-ISO "~Y-~m-~dT~H:~M:~S~z")
(define-constant DATE-FORMAT-ISO-LITERAL (string-append "#" "@" DATE-FORMAT-ISO))

;; Internal helper procedures

(define date-literal-formats
  (let ((+fmts+
          `(,DATE-FORMAT-ISO "~Y-~m-~dT~H:~M:~S"
            "~Y-~m-~d"
            "~H:~M:~S~z" "~H:~M:~S")) )
    (lambda () +fmts+) ) )

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

(define (read-date-literal-string port)
  (read-token (cut string-index DATE-LITERAL-CHARS <>) 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 ((lit-tok (read-date-literal-string port)))
    ;until we got a match or error
    (let loop ((fmts (date-literal-formats)))
      (cond
        ((null? fmts)
          (error 'srfi-19 "invalid date literal" lit-tok))
        ((parse-date-literal lit-tok (car fmts))
          => make-quoted-date)
        (else
          (loop (cdr fmts))) ) ) ) )

(define (write-date-literal dat #!optional (port (current-output-port)))
  (format-date port DATE-FORMAT-ISO-LITERAL dat) )

(define (bracket-date-literals)
  ;default output form
  (set-record-printer! date date-record-formatter)
  ;remove other possible readers
  ;(define-reader-ctor date #f)
  (set-sharp-read-syntax! #\@ #f) )

(define (srfi-10-date-literals)
  ;srfi-10 output form
  (set-record-printer! date date-record-formatter)
  ;remove other possible readers
  ;(set-sharp-read-syntax! #\@ #f)
  ;srfi-10 input handler
  (define-reader-ctor 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
  (set-record-printer! date write-date-literal)
  ;remove other possible readers
  ;(define-reader-ctor date #f)
  ;human legible input handler
  (set-sharp-read-syntax! #\@ read-date-literal) )

;;; Time Literal Syntax

;all chars legal in any time-literal
;#; ;this is of dubious benefit
(define-constant TIME-LITERAL-CHARS "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.+-")

(define-constant TIME-FORMAT-BRACKET "#<~A ~S ~S ~S>")
(define-constant TIME-FORMAT-SRFI-10 "#,(~A ~S ~S ~S)")
;#; ;this is of dubious benefit
(define-constant TIME-FORMAT-LITERAL "##~S~A~S.~S")

;;

;#; ;this is of dubious benefit
(define (read-time-literal-string port)
  (read-token (cut string-index TIME-LITERAL-CHARS <>) port) )

;#; ;this is of dubious benefit
(define read-time-literal
  (let ((+irx+ (irregex '(: ($ (= 3 alpha)) ($ ("-+") (+ num)) #\. ($ (+ num))))))
    (lambda (#!optional (port (current-input-port)))
      (let ((lit-tok (read-time-literal-string port)))
        (let ((lit-mat (irregex-match +irx+ lit-tok)))
          (if (and (irregex-match-data? lit-mat)
                   (= 3 (irregex-match-num-submatches lit-mat)))
              `(make-time
                ;FIXME check time-type
                ',(string->symbol (string-downcase (irregex-match-substring lit-mat 1)))
                ;FIXME check secs sign (+) & number type integer
                ,(string->number (irregex-match-substring lit-mat 3))
                ;FIXME check sec sign (-+) & number type integer
                ,(string->number (irregex-match-substring lit-mat 2)))
              (error 'srfi-19 "invalid time literal" lit-tok) ) ) ) ) ) )

;#; ;this is of dubious benefit
(define (write-time-literal tim #!optional (port (current-output-port)))
  (format port TIME-FORMAT-LITERAL
    (tm:time-type tim)
    (if (negative? (tm:time-second tim)) "-" "+")
    (if (negative? (tm:time-second tim)) (- (tm:time-second tim)) (tm:time-second tim))
    (tm:time-nanosecond tim)) )

(define (bracket-time-literals)
  ;default output form
  (set-record-printer! time time-record-formatter)
  ;remove other possible readers
  ;(define-reader-ctor time #f)
  (set-sharp-read-syntax! #\# #f) )

(define (srfi-10-time-literals)
  ;srfi-10 output form
  (set-record-printer! time time-record-formatter)
  ;remove other possible readers
  ;(set-sharp-read-syntax! #\# #f)
  ;srfi-10 input handler
  (define-reader-ctor time tm:make-time) )

;#; ;this is of dubious benefit
(define (time-literals)
  ;human legible output form
  (set-record-printer! time write-time-literal)
  ;remove other possible readers
  ;(define-reader-ctor time #f)
  ;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)
    time
    (tm:time-type tim)
    (tm:time-second tim)
    (tm:time-nanosecond tim)) )

;;

(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