(module medea

(read-json
 json-parsers
 write-json
 json-unparsers
 json->string)

(import chicken (except scheme string member exp))
(use srfi-14 (except utf8 string) srfi-69 lazy-seq
     (except comparse as-string)
     (prefix utf8-srfi-14 utf8-)
     (only srfi-1 cons* find remove)
     (only data-structures compose constantly identity alist-ref)
     (only utf8-srfi-13 string-concatenate string-pad)
     (only vector-lib vector-for-each)
     (only ports with-output-to-port with-output-to-string))

(define json-parsers
  (make-parameter `((string . ,identity)
                    (number . ,string->number)
                    (member . ,(lambda (name value)
                                 (cons (string->symbol name) value)))
                    (object . ,identity)
                    (array  . ,list->vector))))

(define (parser-ref name)
  (alist-ref name (json-parsers)))

(define (handle-number x)
  (result ((parser-ref 'number) x)))

(define (handle-array args)
  (result ((parser-ref 'array) args)))

(define (handle-member name value)
  (result ((parser-ref 'member ) name value)))

(define (handle-object args)
  (result ((parser-ref 'object) args)))

(define (handle-string string)
  (result ((parser-ref 'string) string)))

(define (handle-unicode u)
  (result (integer->char (string->number u 16))))

(define (handle-escape e)
  (result
   (case e
     ((#\\) #\\)
     ((#\/) #\/)
     ((#\") #\")
     ((#\b) #\backspace)
     ((#\f) #\page)
     ((#\n) #\newline)
     ((#\r) #\return)
     ((#\t) #\tab))))

(define handle-true (constantly (result #t)))
(define handle-false (constantly (result #f)))
(define handle-null (constantly (result 'null)))

(define (as-string parser)
  (sequence* ((parts parser))
    (result (apply conc (remove boolean? parts)))))

(define char-set:json-escaped
  (string->char-set "\"\\/bfnrt"))

(define char-set:json-unescaped
  (utf8-char-set-union
   (utf8-ucs-range->char-set #x20 #x22)
   (utf8-ucs-range->char-set #x23 #x5C)
   (utf8-ucs-range->char-set #x5D #x110000)))

(define char-set:json-char
  (utf8-char-set-union
   utf8-char-set:iso-control
   (utf8-char-set #\" #\\)))

(define (json-char? c)
  (utf8-char-set-contains? char-set:json-char c))

(define consume-trailing-whitespace?
  (make-parameter #f))

(include "grammar.scm")

(define (read-json #!optional (input (current-input-port))
                   #!key (memoize? #t) (consume-trailing-whitespace #t))
  (parameterize ((consume-trailing-whitespace? consume-trailing-whitespace))
    (parse document
           (cond ((input-port? input)
                  (input-port->lazy-seq input read-char))
                 ((string? input)
                  (string->list input))
                 (else input))
           memoize: memoize?)))

(define (unparse-string s)
  (let ((chars (string->list s)))
    (display #\")
    (for-each
     (lambda (c)
       (cond ((utf8-char-set-contains? char-set:json-unescaped c)
              (display c))
             ((char-set-contains? char-set:json-escaped c)
              (display "\\")
              (display c))
             (else
              (display "\\u")
              (display (string-pad (number->string (char->integer c) 16) 4 #\0)))))
     chars)
    (display #\")))

(define (for-each/delimiter proc list delimiter)
  (let ((size (if (vector? list)
                  (vector-length list)
                  (length list)))
        (count 0))
    ((if (vector? list) vector-for-each for-each)
     (lambda (d #!optional (ad d))
       (proc ad)
       (set! count (add1 count))
       (unless (= count size)
         (display #\,)))
     list)))

(define json-unparsers
  (make-parameter
   (list (cons list?
               (lambda (object)
                 (display #\{)
                 (for-each/delimiter
                  (lambda (member)
                    (unparse-string (symbol->string (car member)))
                    (display #\:)
                    (write-json (cdr member)))
                  object
                  #\,)
                 (display #\})))

         (cons vector?
               (lambda (array)
                 (display #\[)
                 (for-each/delimiter write-json array #\,)
                 (display #\])))

         (cons string? unparse-string)
         (cons number? write)
         (cons (cut eq? <> #t) (lambda (o) (display "true")))
         (cons (cut eq? <> #f) (lambda (o) (display "false")))
         (cons (cut eq? <> 'null) (lambda (o) (display "null")))
         (cons (constantly #t)
               (lambda datum
                 (error 'write-json "don't know how to write datum as JSON" datum))))))

(define (write-json object #!optional (port (current-output-port)))
  (with-output-to-port port
    (lambda ()
      ((cdr (find (lambda (unparser)
                    ((car unparser) object))
                  (json-unparsers)))
       object))))

(define (json->string object)
  (with-output-to-string (lambda () (write-json object))))

)