Formatter/parser maker compatible with SRFI-19 date->string/string->date

srfi-19+.scm

;;; -*- mode: scheme; coding: utf-8 -*-

(define-module srfi-19+
  (extend srfi-19)
  (use srfi-1)
  (use srfi-13)
  (use gauche.sequence)
  (use gauche.threads)
  (export make-date-formatter
          make-date-initializer
          make-date-parser))

(select-module srfi-19+)

;; simple memoize function for caching formatter/parser
(define (memoize proc)
  (let1 store (atom (make-hash-table 'string=?))
    (^[fmt]
      (atomic store
              (^[ht]
                (or (hash-table-get ht fmt #f)
                    (let1 v (proc fmt)
                      (hash-table-put! ht fmt v)
                      v)))))))

(define *format-directives*
  (hash-table 'eqv?
              `(#\~ . #\~)
              `(#\a . a)
              `(#\A . A)
              `(#\b . b)
              `(#\B . B)
              ;; depend on current locale.
              `(#\c . (a #\space b #\space d #\space H #\: M #\: S z #\space Y))
              `(#\d . d)
              `(#\D . (m #\/ d #\/ y))
              `(#\e . e)
              `(#\f . f)
              `(#\h . h)
              `(#\H . H)
              `(#\I . I)
              `(#\j . j)
              `(#\k . k)
              `(#\l . l)
              `(#\m . m)
              `(#\M . M)
              `(#\n . #\newline)
              `(#\N . N)
              `(#\p . p)
              `(#\r . (I #\: M #\: S #\space p))
              `(#\s . s)
              `(#\S . S)
              `(#\t . #\tab)
              `(#\T . (H #\: M #\: S))
              `(#\U . U)
              `(#\V . V)
              `(#\w . w)
              `(#\W . W)
              ;; depend on current locale.
              `(#\x . (m #\/ d #\/ y))
              ;; depend on current locale.
              `(#\X . (H #\: M #\: S))
              `(#\y . y)
              `(#\Y . Y)
              `(#\z . z)
              `(#\1 . (Y #\- m #\- d))
              `(#\2 . (H #\: M #\: S z))
              `(#\3 . (H #\: M #\: S))
              `(#\4 . (Y #\- m #\- d #\T H #\: M #\: S z))
              `(#\5 . (Y #\- m #\- d #\T H #\: M #\: S))))

;;
;; Parse format string into S-expression.
;;

(define (parse-format-string fmt)
  (define (rappend head tail)
    (append! (reverse head) tail))
  (with-input-from-string fmt
    (^ []
       (let loop ((c (read-char))
                  (result '()))
         (cond ((eof-object? c) (reverse! result))
               ((char=? c #\~)
                (let* ((c (read-char))
                       ;; Gauche extension: ~@x calls the directive 'x' with locale
                       ;; set to C, so the caller can guarantee the output.  Currently
                       ;; the library only supports the default locale, so we can simply
                       ;; ignore '@'.  In future we'll add locale-sensitive stuff.
                       (c (if (char=? #\@ c)
                              (read-char)
                              c)))
                  (cond ((hash-table-get *format-directives* c #f) =>
                         (^ [directive]
                            (loop (read-char)
                                  (if (list? directive)
                                      (rappend directive result)
                                      (cons directive result)))))
                        ((eof-object? c) (error "Unexpected end in format string: " fmt))
                        (else (error "Unknown format directive: " c)))))
               (else (loop (read-char) (cons c result))))))))

;;
;; Date String Formatter (compatible with date->string)
;;

(define (make-date-formatter fmt)
  (let* ((parsed-fmt (map (^e (cond ((symbol? e)
                                     (or (hash-table-get *output-directives* e #f)
                                         (error "Unsupported print directive: " e)))
                                    ((char? e) e)
                                    (else "Unexpected element in the template: " e)))
                          (parse-format-string fmt)))
         (format-fmt (with-output-to-string
                       (^ [] (for-each (^e (cond ((list? e) (display (car e)))
                                                 ((eqv? e #\~) (display "~~"))
                                                 (else (write-char e))))
                                       parsed-fmt))))
         (getter-chain (filter-map (^e (and (list? e) (cadr e))) parsed-fmt)))
    (^ [out obj] (apply format out format-fmt (map (cut <> obj) getter-chain)))))

(define *output-directives*
  (let ((secondF (^o (let1 s (format "~d~a~9,'0d" (date-second o)
                                     tm:locale-number-separator (date-nanosecond o))
                       (string-trim-right s #\0))))
        (hour12 (^o (let1 h (date-hour o)
                      (case h
                        ((0 12) 12)
                        (else
                         (if (< h 12)
                             h
                             (- h 12)))))))
        (zone822 (^o (let* ((offset (date-zone-offset o))
                            (sign (if (< offset 0) #\- #\+))
                            (min (quotient (abs offset) 60)))
                       (format "~a~2,'0d~2,'0d" sign (quotient min 60) (remainder min 60)))))
        )
    (hash-table 'eq?
                `(a "~a" ,(^o (tm:locale-abbr-weekday (date-week-day o))))
                `(A "~a" ,(^o (tm:locale-long-weekday (date-week-day o))))
                `(b "~a" ,(^o (tm:locale-abbr-month (date-month o))))
                `(B "~a" ,(^o (tm:locale-long-month (date-month o))))
                `(d "~2,'0d" ,date-day)
                `(e "~2,' d" ,date-day)
                `(f "~a" ,secondF)
                `(H "~2,'0d" ,date-hour)
                `(I "~2,'0d" ,hour12)
                `(j "~3,'0d" ,date-year-day)
                `(k "~2,' d" ,date-hour)
                `(l "~2,' d" ,hour12)
                `(m "~2,'0d" ,date-month)
                `(M "~2,'0d" ,date-minute)
                `(N "~9,'0d" ,date-nanosecond)
                `(p "~a" ,(.$ tm:locale-am/pm date-hour))
                `(s "~d" ,(.$ (cut slot-ref <> 'second) date->time-utc))
                `(S "~2,'0d" ,date-second)
                `(U "~2,'0d" ,(^o (if (> (tm:days-before-first-week o 0) 0)
                                      (+ (date-week-number o 0) 1)
                                      (date-week-number o 0))))
                `(V "~2,'0d" ,(cut date-week-number <> 1))
                `(w "~d" ,date-week-day)
                `(W "~2,'0d" ,(^o (if (> (tm:days-before-first-week o 1) 0)
                                      (+ (date-week-number o 1) 1)
                                      (date-week-number o 1))))
                `(y "~2,'0d" ,(^o (remainder (date-year o) 100)))
                `(Y "~d" ,date-year)
                `(z "~a" ,zone822))))

;;
;; Date String Parser (compatible with string->date)
;;

(define (make-date-parser fmt)
  (let1 initializer (make-date-initializer fmt)
    (cut initializer <> (make-date 0 0 0 0 #f #f #f (tm:local-tz-offset)))))

(define (make-date-initializer fmt)
  (let1 parser-chain (map (^ [elem]
                             (cond ((symbol? elem)
                                    (or (hash-table-get *input-directives* elem #f)
                                        (error "Unsupported read directive: " elem)))
                                   (else elem)))
                          (parse-format-string fmt))
    (^ [in obj]
       (for-each (^ [elem]
                    (cond ((procedure? elem) (elem in obj))
                          ((char? elem) (skip-char-literal in elem))
                          (else (error "Unknown parser element: " elem))))
                 parser-chain)
       obj)
    ))

(define (skip-until pred in)
  (let loop ((c (peek-char in)))
    (unless (pred c)
      (read-char in)                    ;; skip
      (loop (peek-char in)))))

(define (read-digits in verifier)
  (let1 value (let loop ((c (peek-char in))
                         (count 0)
                         (accum 0))
                (cond ((eof-object? c)
                       (if (zero? count)
                           (error "Unexpected end of input.")
                           accum))
                      ((char-set-contains? #[\d] c)
                       (read-char in) ; and ignore
                       (loop (peek-char in) (+ 1 count) (+ (* 10 accum) (tm:char->int c))))
                      (else accum)))
    (cond ((not verifier) value)
          ((verifier value) value)
          (else (error "Invalid value: " value)))))

(define (read-n-digits in max pad-char verifier)
  (let* ((count (if pad-char
                    (let loop ((c (peek-char in))
                               (count 0))
                      (cond ((eof-object? c) (error "Unexpected end of input."))
                            ((>= count max) (error "Too many padding character:" pad-char))
                            ((char-set-contains? #[\d] c) count)
                            ((char=? c pad-char)
                             (read-char in) ; and ignore
                             (loop (peek-char in) (+ 1 count)))))
                    0))
         (value (let loop ((c (peek-char in))
                           (count count)
                           (accum 0))
                  (cond ((or (>= count max) (eof-object? c)) accum)
                        ((char-set-contains? #[\d] c)
                         (read-char in) ; and ignore
                         (loop (peek-char in) (+ 1 count)
                               (+ (* accum 10) (tm:char->int c))))
                        (else accum)))))
    (cond ((not verifier) value)
          ((verifier value) value)
          (else (error "Invalid value:" value)))))

(define (skip-char-literal in char)
  (let1 c (peek-char in)
    (cond ((eof-object? c) (error "Unexpected end of input."))
          ((char=? char c) (read-char in)) ; and ignore
          (else (errorf "Required ~s as input character but got ~s" char c)))))

(define (make-date-reader-setter skipper reader setter)
  (^[in obj]
    (skipper in)
    (setter obj (reader in))))

(define (make-lexical-tree words)
  (define (lexical-tree-put! ht word value)
    (let loop ((word (string->list word))
               (node ht))
      (unless (null? word)
        (receive (c word) (car+cdr word)
          (cond ((null? word)
                 (hash-table-put! node c value))
                ((hash-table-get node c #f) =>
                 (cut loop word <>))
                ((hash-table 'eqv?) =>
                 (^n (hash-table-put! node c n)
                     (loop word n)))))))
    ht)

  (fold-with-index (^ [i w ht] (lexical-tree-put! ht w i))
                   (hash-table 'eqv?) words))

(define weekday-tree (make-lexical-tree tm:locale-long-weekday-vector))
(define weekday-abbr-tree (make-lexical-tree tm:locale-abbr-weekday-vector))
(define month-tree (make-lexical-tree tm:locale-long-month-vector))
(define month-abbr-tree (make-lexical-tree tm:locale-abbr-month-vector))
(define am/pm-tree (make-lexical-tree `(,tm:locale-am ,tm:locale-pm)))

(define (read-word in ht)
  (let loop ((node ht)
             (c (read-char in)))
    (cond ((eof-object? c) (error "Unexpected end of input."))
          ((hash-table-get node c #f) =>
           (^n (if (hash-table? n)
                   (loop n (read-char in))
                   n)))
          (else (error "Unexpected character:" c)))))

(define (read-second-as-float in obj)
  (skip-until #[\d] in)
  (let1 s (read-digits in (cut <= 0 <> 60))
    (skip-char-literal in #\.)
    (let1 c (peek-char in)
      (when (eof-object? c) (error "Unexpected end of input."))
      (let1 ns (let loop ((c c)
                          (max 9)
                          (accum 0))
                 (cond ((<= max 0) accum)
                       ((eof-object? c) (loop c (- max 1) (* 10 accum)))
                       ((char-set-contains? #[\d] c)
                        (read-char in) ; and ignore
                        (loop (peek-char in) (- max 1) (+ (tm:char->int c) (* 10 accum))))
                       (else (loop c (- max 1) (* 10 accum)))))
        (slot-set! obj 'second s)
        (slot-set! obj 'nanosecond ns)
        ))))

(define (ignore _ _)
  (undefined))

(define *input-directives*
  (let ((wday-abbr (make-date-reader-setter
                    (pa$ skip-until #[\w])
                    (cut read-word <> weekday-abbr-tree)
                    ignore))
        (wday-long (make-date-reader-setter
                    (pa$ skip-until #[\w])
                    (cut read-word <> weekday-tree)
                    ignore))
        (month-abbr (make-date-reader-setter
                     (pa$ skip-until #[\w])
                     (cut read-word <> month-abbr-tree)
                     (cut slot-set! <> 'month <>)))
        (month-long (make-date-reader-setter
                     (pa$ skip-until #[\w])
                     (cut read-word <> month-tree)
                     (cut slot-set! <> 'month <>)))
        (day0 (make-date-reader-setter
               (pa$ skip-until #[\d])
               (cut read-n-digits <> 2 #\0 (cut <= 0 <> 31))
               (cut slot-set! <> 'day <>)))
        (dayS (make-date-reader-setter
               (pa$ skip-until #[\d ])
               (cut read-n-digits <> 2 #\space (cut <= 0 <> 31))
               (cut slot-set! <> 'day <>)))
        (secondF read-second-as-float)
        (hour24 (make-date-reader-setter
                 (pa$ skip-until #[\d])
                 (cut read-n-digits <> 2 #\0 (cut <= 0 <> 23))
                 (cut slot-set! <> 'hour <>)))
        (hour12 (make-date-reader-setter
                 (pa$ skip-until #[\d])
                 (cut read-n-digits <> 2 #\0 (cut <= 1 <> 12))
                 (^ [o v]
                    (let1 old-v (slot-ref o 'hour)
                      (if (= 12 old-v)
                          (slot-set! o 'hour (+ v old-v)) ; FIXME
                          (slot-set! o 'hour v))))))
        (hour24S (make-date-reader-setter
                  (pa$ skip-until #[\d ])
                  (cut read-n-digits <> 2 #\space (cut <= 0 <> 23))
                  (cut slot-set! <> 'hour <>)))
        (hour12S (make-date-reader-setter
                  (pa$ skip-until #[\d ])
                  (cut read-n-digits <> 2 #\space (cut <= 1 <> 12))
                  (^ [o v]
                     (let1 old-v (slot-ref o 'hour)
                       (if (= 12 old-v)
                           (slot-set! o 'hour (+ v old-v)) ; FIXME
                           (slot-set! o 'hour v))))))
        (month (make-date-reader-setter
                (pa$ skip-until #[\d])
                (cut read-n-digits <> 2 #\0 (cut <= 1 <> 12))
                (cut slot-set! <> 'month <>)))
        (minute (make-date-reader-setter
                 (pa$ skip-until #[\d])
                 (cut read-n-digits <> 2 #\0 (cut <= 0 <> 59))
                 (cut slot-set! <> 'minute <>)))
        (nanosecond (make-date-reader-setter
                     (pa$ skip-until #[\d])
                     (cut read-n-digits <> 9 #\0 #f)
                     (cut slot-set! <> 'nanosecond <>)))
        (am/pm (make-date-reader-setter
                (pa$ skip-until #[\w])
                (cut read-word <> am/pm-tree)
                (^ [o v]
                   (let1 old-v (slot-ref o 'hour)
                     (slot-set! o 'hour (+ (remainder old-v 12) (* v 12)))))))
        (second (make-date-reader-setter
                 (pa$ skip-until #[\d])
                 (cut read-n-digits <> 2 #\0 (cut <= 0 <> 60))
                 (cut slot-set! <> 'second <>)))
        (sec-from-epoch (make-date-reader-setter
                         (pa$ skip-until #[\d])
                         (cut read-digits <> #f)
                         (^ [o v]
                            (let1 d ($ time-utc->date $ make-time 'time-utc 0 v)
                              (for-each (^n (slot-set! o n (slot-ref d n)))
                                        (map car (class-direct-slots (class-of d))))))))
        (nyear (make-date-reader-setter
                (pa$ skip-until #[\d])
                (cut read-n-digits <> 2 #\0 (cut <= 0 <> 99))
                (^ [o v] (slot-set! o 'year (tm:natural-year v)))))
        (year (make-date-reader-setter
               (pa$ skip-until #[\d])
               (cut read-digits <> #f)
               (cut slot-set! <> 'year <>)))
        (zone822 (make-date-reader-setter
                  (pa$ skip-until #[-+Zz])
                  tm:zone-reader (cut slot-set! <> 'zone-offset <>)))
        )
    (hash-table 'eq?
                `(a . ,wday-abbr)
                `(A . ,wday-long)
                `(b . ,month-abbr)
                `(B . ,month-long)
                `(d . ,day0)
                `(e . ,dayS)
                `(f . ,secondF)
                `(H . ,hour24)
                `(I . ,hour12)
                `(k . ,hour24S)
                `(l . ,hour12S)
                `(m . ,month)
                `(M . ,minute)
                `(N . ,nanosecond)
                `(p . ,am/pm)
                `(s . ,sec-from-epoch)
                `(S . ,second)
                `(y . ,nyear)
                `(Y . ,year)
                `(z . ,zone822)
                )))

(define date->string
  (let1 make-date-formatter (memoize make-date-formatter)
    (^ [date . maybe-fmtstr]
       (let1 format-string (get-optional maybe-fmtstr "~c")
         ((make-date-formatter format-string) #f date)))))

(define string->date
  (let1 make-date-parser (memoize make-date-parser)
    (^ [input-string template-string]
       (call-with-input-string input-string
         (make-date-parser template-string)))))