;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax helpers

;; like let-optionals* but uses the default even when the parameter is
;; specified if it's false
(define-syntax let-params*
  (syntax-rules ()
    ((_ ls () . body) (begin . body))
    ((_ ls ((var default) rest ...) . body)
     (let* ((tmp ls)
            (var (or (if (pair? tmp) (car tmp) #f) default)))
       (let-params* (if (pair? tmp) (cdr tmp) '()) (rest ...) . body)))
    ((_ ls ((var) rest ...) . body)
     (let-params* ls ((var #f) rest ...) . body))))

(define-syntax get-optional
  (syntax-rules ()
    ((_ ls default)
     (let ((tmp ls))
       (if (pair? tmp) (car tmp) default)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; list helpers (non-strict variants of SRFI-1 procedures)

(define (list-ref* ls i . opt)
  (let loop ((l ls) (j 0))
    (if (null? l)
      (if (pair? opt) (car opt) (error "invalid index:" i))
      (if (= i j)
        (car l)
        (loop (cdr l) (+ j 1))))))

(define (split-at* ls i)
  (let loop ((res '()) (l ls) (j i))
    (if (or (zero? j) (null? l))
      (values (reverse res) l)
      (loop (cons (car l) res) (cdr l) (- j 1)))))

(define (take* ls i)
  (receive (t d) (split-at* ls i) t))

(define (drop* ls i)
  (receive (t d) (split-at* ls i) d))

(define identity (lambda (x) x))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dispatch-based format objects

(define (make-formatter parents specs . opt)
  (let-params* opt
      ((strict? (any (cut <> 'strict?) parents))
       (case-sensitive? (any (cut <> 'case-sensitive?) parents))
       (ignore-params? (any (cut <> 'ignore-params?) parents))
       (start-char (or (any (cut <> 'start-char) parents) #\~))
       (param-char (or (any (cut <> 'param-char) parents) #\,))
       (quote-char (or (any (cut <> 'quote-char) parents) #\'))
       (key-chars (concatenate (map (cut <> 'key-chars) parents))))
    (let* ((hi (fold (lambda (x res) (max (char->integer (car x)) res))
                     (fold (lambda (p m) (max (- (vector-length (p 'table)) 1) m))
                           0 parents)
                     specs))
           (vec (make-vector (+ hi 1) #f))
           (taker (if strict? take take*))
           (dropper (if strict? drop drop*))
           (splitter (if strict? split-at split-at*)))
      (define (digits->number ls)
        (string->number (list->string (reverse ls))))
      (define (parse-format)
        (let loop ((p '())  ;; params
                   (d '())  ;; digits
                   (k '())) ;; key-chars
          (define (validate-new-param pass)
            (if (pair? k)
              (error "format: key-chars must come after positional arguments")
              (pass)))
          (let ((c (read-char)))
            (if (eof-object? c)
              (error "incomplete format string, expected char after" start-char)
              (cond
                ((eqv? c param-char)
                 (validate-new-param
                  (lambda () (loop (cons (if (pair? d) (digits->number d) #f) p) '() k))))
                ((eqv? c quote-char)
                 (validate-new-param
                  (lambda ()
                    (let ((c2 (read-char)))
                      (if (eof-object? c2)
                        (error "incomplete format string, expected char after" quote-char)
                        (if (pair? d)
                          (if strict?
                            (error "no separator between positional parameters")
                            (loop (cons c2 (cons (digits->number d) p)) '() k))
                          (loop (cons c2 p) '() k)))))))
                ((memv c key-chars)
                 (loop p d (cons c k)))
                ((and (not ignore-params?) ;; allow numeric format chars if no params
                      (memv c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\. #\/ #\+ #\-)))
                 (validate-new-param (lambda () (loop p (cons c d) k))))
                (else
                 (let* ((params (reverse (if (pair? d) (cons (digits->number d) p) p)))
                        (i (char->integer c))
                        (spec (if (> i hi) #f (vector-ref vec i))))
                   (if spec
                     (let-params* spec ((builder)
                                        (num-use 1)
                                        (num-consume num-use)
                                        (ignore? ignore-params?))
                       (let ((f (builder params k)))
                         (cond
                           ((procedure? num-use)
                            (num-use f params k))
                           ((eqv? num-use num-consume)
                            (if ignore?
                              (if (eqv? num-use 1)
                                (lambda (args) (f (car args)) (cdr args))
                                (lambda (args)
                                  (receive (u r) (splitter args num-use)
                                    (f u)
                                    r)))
                              (lambda (args)
                                (receive (u r) (splitter args num-use)
                                  (apply f (append u params))
                                  r))))
                           (else
                            (if ignore?
                              (if (eqv? num-use 1)
                                (if (zero? num-consume)
                                  (lambda (args) (f (car args)) args)
                                  (lambda (args)
                                    (f (car args))
                                    (dropper args num-consume)))
                                (lambda (args)
                                  (apply f (taker args num-use))
                                  (dropper args num-consume)))
                              (lambda (args)
                                (apply f (append (taker args num-use) params))
                                (dropper args num-consume)))))))
                     (error "unknown format char:" c)))))))))
      (define (static-formatter str)
        (with-input-from-string str
          (lambda ()
            (let loop ((proc identity)
                       (literals '()))
              (let ((c (peek-char)))
                (cond
                  ((eof-object? c)
                   (if strict?
                     (lambda (args)
                       (let ((remaining (proc args)))
                         (if (pair? remaining)
                           (error "too many arguments to format:" args))))
                     proc))
                  ((or (eq? start-char #t) (eqv? c start-char))
                   (if (char? start-char) (read-char))
                   (let ((f (parse-format)))
                     (if (null? literals)
                       (loop (lambda (args) (f (proc args))) '())
                       (let ((str (list->string (reverse literals))))
                         (loop (lambda (args) (let ((tmp (proc args))) (display str) (f tmp))) '())))))
                  (else
                   (read-char)
                   (loop proc (cons c literals)))))))))
      (define (formatter x . args)
        (cond
          ((string? x)
           (with-output-to-string 
             (lambda () ((static-formatter x) args))))
          ((port? x)
           (with-output-to-port x
             (lambda () ((static-formatter (car args)) (cdr args)))))
          ((eq? x #t)
           (apply (static-formatter (car args)) (cdr args)))
          ((eq? x #f)
           (with-output-to-string
             (lambda () ((static-formatter (car args)) (cdr args)))))
          (else (error "invalid initial format argument"))))
      ;; build the table
      (for-each
       (lambda (p)
         (let ((p-tab (p 'table)))
           (do ((i (- (vector-length p-tab) 1) (- i 1)))
               ((negative? i))
             (vector-set! vec i (vector-ref p-tab i)))))
       parents)
      (for-each
       (lambda (x)
         (let ((c (car x)) (s (cdr x)))
           (if case-sensitive?
             (vector-set! vec (char->integer c) s)
             (begin
               (vector-set! vec (char->integer (char-downcase c)) s)
               (vector-set! vec (char->integer (char-upcase c)) s)))))
       specs)
      ;; return the dispatch closure
      (lambda (command . args)
        (case command
          ((static-formatter)
           (static-formatter (car args)))
          ((formatter)
           formatter)
          ((format)
           (apply formatter args))
          ;; introspection
          ((table) vec)                       ((strict?) strict?)
          ((case-sensitive?) case-sensitive?) ((ignore-params?) ignore-params?)
          ((start-char) start-char)           ((param-char) param-char)
          ((quote-char) quote-char)           ((key-chars)  key-chars)
          (else (error "unknown formatter command:" command)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Examples
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-28 format

(define srfi-28-formatter
  (make-formatter '()
    `((#\a ,(lambda _ display)) (#\s ,(lambda _ write)))
    #t))

(define srfi-28-format (srfi-28-formatter 'formatter))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-48 format

(define srfi-48-formatter
  (make-formatter (list srfi-28-formatter)
    (map
     (lambda (x) (append (list (car x) (lambda _ (cadr x))) (cddr x)))
     `((#\b ,(lambda (x) (display (number->string x 2))))
       (#\o ,(lambda (x) (display (number->string x 8))))
       (#\d ,(lambda (x) (display (number->string x 10))))
       (#\x ,(lambda (x) (display (number->string x 16))))
       ))))

(define srfi-48-format (srfi-48-formatter 'formatter))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-19 date format

;; number-grow is (compose string-grow number->string) and pads w/ 0
(define (number-grow num len . opt)
  (let* ((str (number->string num))
         (off (- len (string-length str)))
         (pad (get-optional opt #f)))
    (if (and (positive? off) pad)
      (string-append (make-string off pad) str)
      str)))

(define srfi-19-base-formatter
  (make-formatter '()
    (append
     (map
      (lambda (x) (let ((f (cadr x))) (list (car x) (lambda _ f) (list-ref* x 2 1) (list-ref* x 3 0))))
      `((#\~ ,(lambda (x) (display #\~)) 0)
        (#\a ,(lambda (x) (display (tm:locale-abbr-weekday (date-week-day x)))))
        (#\A ,(lambda (x) (display (tm:locale-long-weekday (date-week-day x)))))
        (#\b ,(lambda (x) (display (tm:locale-abbr-month (date-month x)))))
        (#\B ,(lambda (x) (display (tm:locale-long-month (date-month x)))))
        (#\c ,(lambda (x) (display (date->string x tm:locale-date-time-format))))
        (#\d ,(lambda (x) (display (number-grow (date-day x) 2))))
        (#\e ,(lambda (x) (display (number-grow (date-day x) 2))))
        (#\h ,(lambda (x) (display (tm:locale-abbr-month (date-month x)))))
        (#\k ,(lambda (x) (display (number-grow (date-hour x) 2))))
        (#\l ,(lambda (x)
                (let ((hr (date-hour x)))
                  (display (number-grow (if (> hr 12) (- hr 12) hr) 2)))))
        (#\n ,(lambda (x) (newline)))
        (#\p ,(lambda (x) (display (tm:locale-am/pm (date-hour x)))))
        (#\s ,(lambda (x) (display (time-second (date->time-utc x)))))
        (#\t ,(lambda (x) (display #\tab)))
        (#\U ,(lambda (x)
                (display
                 (number-grow
                  (if (> (tm:days-before-first-week x 0) 0)
                    (+ (date-week-number x 0) 1)
                    (date-week-number x 0))
                  2))))
        (#\V ,(lambda (x) (display (number-grow (date-week-number x 1) 2))))
        (#\w ,(lambda (x) (display (date-week-day x))))
        (#\x ,(lambda (x) (display (date->string x tm:locale-short-date-format))))
        (#\X ,(lambda (x) (display (date->string x tm:locale-time-format))))
        (#\W ,(lambda (x)
                (display
                 (number-grow
                  (if (> (tm:days-before-first-week x 1) 0)
                    (+ (date-week-number x 1) 1)
                    (date-week-number x 1))
                  2))))
        (#\Y ,(lambda (x) (display (date-year x))))
        (#\z ,(lambda (x) (tm:tz-printer (date-zone-offset x))))
        (#\Z ,(lambda (x) (tm:locale-print-time-zone x)))
        ))
     ;; padding
     (map
      (lambda (x) (list (car x)
                   (lambda (params keys)
                     (let ((p (cond ((memv #\_ keys) #\space)
                                    ((memv #\- keys) #f)
                                    (else #\0)))
                           (f (cadr x)))
                       (lambda (y) (f y p))))
                   (list-ref* x 3 1) (list-ref* x 4 0)))
      `((#\f ,(lambda (x p)
                (display (number-grow (date-second x) 2 p))
                (display tm:locale-number-separator)
                (let ((nanostr (number->string (/ (date-nanosecond x) tm:nano))))
                  (cond ((string-index nanostr #\.)
                         => (lambda (i) (display (string-drop nanostr (+ i 1)))))))))
        (#\H ,(lambda (x p) (display (number-grow (date-hour x) 2 p))))
        (#\I ,(lambda (x p)
                (let ((hr (date-hour x)))
                  (display (number-grow (if (> hr 12) (- hr 12) hr) 2 p)))))
        (#\j ,(lambda (x p) (display (number-grow (date-year-day x) 3 p))))
        (#\m ,(lambda (x p) (display (number-grow (date-month x) 2 p))))
        (#\M ,(lambda (x p) (display (number-grow (date-minute x) 2 p))))
        (#\N ,(lambda (x p) (display (number-grow (date-nanosecond x) 9 p))))
        (#\S ,(lambda (x p) (display (number-grow (date-second x) 2 p))))
        (#\y ,(lambda (x p)
                (display (number-grow (tm:last-n-digits (date-year x) 2) 2 p))))
        )))
    #f #t #t #f #f #f '(#\- #\_)))

(define srfi-19-formatter
  (make-formatter (list srfi-19-base-formatter)
    (map
     (lambda (x) (let ((f (lambda ls ((cadr x) ls)))) (list (car x) (lambda _ f) 1 0)))
     `((#\D ,(srfi-19-base-formatter 'static-formatter "~m/~d/~y"))
       (#\r ,(srfi-19-base-formatter 'static-formatter "~I:~M:~S ~p"))
       (#\T ,(srfi-19-base-formatter 'static-formatter "~H:~M:~S"))
       (#\1 ,(srfi-19-base-formatter 'static-formatter "~Y-~m-~d"))
       (#\2 ,(srfi-19-base-formatter 'static-formatter "~k:~M:~S~z"))
       (#\3 ,(srfi-19-base-formatter 'static-formatter "~k:~M:~S"))
       (#\4 ,(srfi-19-base-formatter 'static-formatter "~Y-~m-~dT~k:~M:~S~z"))
       (#\5 ,(srfi-19-base-formatter 'static-formatter "~Y-~m-~dT~k:~M:~S"))
       ))))

(define srfi-19-format (srfi-19-formatter 'formatter))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; printf

(define printf-formatter
  (make-formatter '()
    (map
     (lambda (x) (list (car x) (lambda _ (cadr x))))
     `((#\d ,(lambda (x . o)
               (let-params* o ((w) (p))
                 (display
                  (if p (format-fixed x #f w p)
                      (if w (number-grow x w #\space)
                          (number->string x)))))))
       (#\o ,(lambda (x . o)
               (let-params* o ((w))
                 (display
                  ((if w (cut string-grow <> w #\space) identity)
                   (number->string x 8))))))
       (#\x ,(lambda (x . o)
               (let-params* o ((w))
                 (display
                  ((if w (cut string-grow <> w #\space) identity)
                  (number->string x 16))))))
       (#\s ,(lambda (x . o)
               (let-params* o ((w))
                 (display
                  (if w (string-grow x w #\space) x)))))
       ))
    #f #t #f #\% #\. #f
    '(#\h #\l #\L #\- #\+ #\space #\# #\')))

(define printf (printf-formatter 'formatter))

;; same rules but uses ~ instead of %
(define printf-tilde-formatter
  (make-formatter (list printf-formatter)
    '()
    #f #t #f #\~ #\,))

(define printf-tilde (printf-tilde-formatter 'formatter))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Common-Lisp style format, minus programmatic features

;; like R5RS round, but handle optional scale=0, base=10
;;   (round* 3.14)         => 3
;;   (round* 3.14 -1)      => 3.1
;;   (round* #xDEAD 2 16)  => #xDF00
(define (round* n . opt)
  (let-params* opt ((scale 0)
                    (base 10))
    (let ((mid (if (even? base) (quotient base 2) -1)))
      (if (negative? scale)
        (let* ((one (expt base (- scale)))
               (n2 (* n one))
               (whole (truncate n2))
               (part (* base (- n2 whole))))
          (/
           (if (or (> part mid)
                   (and (= part mid) (odd? (remainder whole one))))
             (+ whole 1)
             whole)
           one))
        (let* ((one (expt base scale))
               (n2 (inexact->exact (round n)))
               (whole (quotient n2 one))
               (part (remainder n2 one)))
          (* one
             (if (or (> part mid)
                     (and (= part mid) (odd? (remainder whole one))))
               (+ whole 1)
               whole)))))))

;; string-grow is like string-pad but never makes string shorter
(define (string-grow str len . opt)
  (let ((off (- len (string-length str))))
    (if (positive? off)
      (string-append (make-string off (get-optional opt #\space)) str)
      str)))
(define (string-grow-right str len . opt)
  (let ((off (- len (string-length str))))
    (if (positive? off)
      (string-append str (make-string off (get-optional opt #\space)))
      str)))

;; intersperse* is like intersperse but takes an optional interval
(define (intersperse* x ls . opt)
  (if (null? ls)
    ls
    (let ((interval (get-optional opt 1))
          (res (list (car ls))))
      (do ((l (cdr ls) (cdr l))
           (i 1 (+ i 1)))
          ((null? l) (reverse! res))
        (when (= i interval)
          (set! i 0)
          (push! res x))
        (push! res (car l))))))

(define (intersperse-right x ls . opt)
  (reverse (apply intersperse* x (reverse ls) opt)))
(define (intersperse-string ch str . opt)
  (list->string (apply intersperse* ch (string->list str) opt)))
(define (intersperse-string-right ch str . opt)
  (list->string (apply intersperse-right ch (string->list str) opt)))

(define (prepend-plus +sign? num . opt)
  (let ((str (get-optional opt (number->string num))))
    (if (and +sign? (positive? num))
      (string-append "+" str)
      str)))

(define (char-name ch)
  (let* ((n1 (char->integer ch))
         (n2 (if (negative? n1) (+ n1 128) n1)))
    (if (<= 32 n2 )
      ch
      (string-append "#\\x" (number->string n2 16)))))

(define (format-fixed num +sign? . opt)
  (let-params* opt ((width)
                    (digits)
                    (scale 0)
                    (overflow-ch)
                    (pad-ch #\space))
    (display
     (let* ((n1 (abs (if (or (not scale) (zero? scale))
                       num (* num (expt 10 scale)))))
            (s1 (number->string n1))
            (d1 (string-index s1 #\.))
            (l1 (string-length s1))
            (req-width (or d1 l1))
            (prefix ""))
       (when (or (negative? num) +sign?)
         (set! prefix (if (negative? num) "-" "+"))
         (when width (inc! req-width)))
       (if (and width (> (+ req-width (if digits (+ digits 1) 0)) width) overflow-ch)
         (make-string (+ (string-length prefix) width) overflow-ch)
         (let* ((real-digits
                 (or digits (and width (- width req-width 1))))
                (n2 (if real-digits (round* n1 (- real-digits)) n1))
                (s2 (number->string n2))
                (d2 (string-index s2 #\.))
                (l2 (string-length s2)))
           ((if width (cut string-grow <> width) identity)
            (string-append
             prefix
             (if digits
               (string-pad-right s2 (+ digits (or d2 l2) 1) #\0)
               s2)))))))))