Skip to content

Instantly share code, notes, and snippets.

@bizenn
Last active June 29, 2018 09:10
Show Gist options
  • Save bizenn/5105899 to your computer and use it in GitHub Desktop.
Save bizenn/5105899 to your computer and use it in GitHub Desktop.
Formatter/parser maker compatible with SRFI-19 date->string/string->date
;;; -*- 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)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment