(module medea

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

(import chicken scheme)
(use srfi-14 srfi-69 lazy-seq
     (except comparse)
     (only srfi-1 cons* find remove)
     (only data-structures compose constantly identity alist-ref conc string-translate*)
     (only srfi-13 string-pad string-index substring/shared string-concatenate-reverse/shared)
     (only ports with-output-to-port with-output-to-string))

(define (vector-for-each proc vec)
  (let ((len (vector-length vec)))
    (do ((i 0 (fx+ i 1)))
        ((fx>= i len))
      (proc (vector-ref vec i)))))

(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 (##sys#char->utf8-string (integer->char u))))

(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 json-escape-chars
  "\"\\bfnrt/")

(define json-escapes
  (map (lambda (e c)
         (cons (string e) (string #\\ c)))
       (string->list "\"\\\b\f\n\r\t")
       (string->list json-escape-chars)))

(define char-set:json-escape
  (string->char-set json-escape-chars))

(define char-set:json-char
  (char-set-union
   (ucs-range->char-set #x0 #x20)
   (char-set #\" #\\)))

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

(define document
  (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 control-chars
  (ucs-range->char-set #x0 #x20))

(define (display/escape-control-chars s)
  (let loop ((i 0))
    (let ((j (string-index s control-chars i)))
      (if j
          (begin
            (display (substring/shared s i j))
            (display "\\u")
            (display (string-pad (number->string (char->integer (string-ref s j)) 16) 4 #\0))
            (loop (+ j 1)))
          (display (substring/shared s i))))))

(define (unparse-string s)
  (display #\")
  (display/escape-control-chars (string-translate* s json-escapes))
  (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))))

)