;;; (fff json) --- serialize fff to json
;; NOTE: serialization does NOT work the other way---my thinking is, if you've
;; got data in json, it's already too complex for fff.

(import (scheme base)
        (chicken format)
        (chicken string)
        (srfi 14)
        (utf8)
        (fff read))

(define (fff->json fff)
  (cond
   ((list? fff)
    (string-append "{"
                   (string-intersperse (map fff->json fff) ",")
                   "}"))
   ((vector? fff)
    (string-append "["
                   (string-intersperse
                    (vector->list (vector-map fff->json fff))
                    ",")
                   "]"))
   ((pair? fff)
    (string-append (fff->json (car fff))
                   ":"
                   (fff->json (cdr fff))))
   ((eq? fff #t) "true")
   ((eq? fff #f) "false")
   ((eq? fff 'null) "null")
   ((string? fff) (string-append "\"" (escape-json-string fff) "\""))
   ((number? fff) (number->string fff))
   (else (error "Bad type" fff))))

(define (escape-json-string str)
  (let loop ((cs (string->list str))
             (acc '()))
    (if (null? cs)
        (list->string (reverse acc))
        (loop (cdr cs)
              (append (let ((c (car cs)))
                        (cond
                         ((memq c '(#\\ #\" #\/ #\backspace #\page
                                    #\newline #\return #\tab))
                          (case c
                            ((#\\)      ; reverse solidus
                             '(#\\ #\\))
                            ((#\")      ; quotation mark
                             '(#\" #\\))
                            ((#\/)      ; solidus
                             '(#\/ #\\))
                            ((#\backspace)
                             '(#\b #\\))
                            ((#\page)   ; form-feed
                             '(#\f #\\))
                            ((#\newline) ; linefeed
                             '(#\n #\\))
                            ((#\return) ; carriage return
                             '(#\r #\\))
                            ((#\tab)    ; horizontal tab
                             '(#\t #\\))))
                         ((and (not (char-set-contains? char-set:ascii c))
                               (not (char-set-contains?
                                     char-set:iso-control c)))
                          (reverse
                           (string->list (string-append
                                          "\\u"
                                          (zero-pad-hex (char->integer c))))))
                         (else (list c))))
                      acc)))))

(define (zero-pad-hex n)
  (let ((x (sprintf "~x" n)))
    (case (string-length x)
      ((1) (string-append "000" x))
      ((2) (string-append "00" x))
      ((3) (string-append "0" x))
      (else x))))