(module medea

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

(import chicken scheme)
(use genturfahi srfi-14 utf8 (prefix utf8-srfi-14 utf8-)
     (only srfi-1 cons* find)
     (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))

(begin-for-syntax
 (import chicken)
 (use genturfahi-peg))

(define-syntax load-peg
  (ir-macro-transformer
   (lambda (x i c)
     (let* ((file (cadr x))
            (grammar (call-with-input-file file genturfahi-peg)))
       (if grammar
           `(genturfahi ,grammar)
           (error "could not parse PEG file" file))))))

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


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

(define (as-string . args)
  (list->string (apply cons* args)))

(define (as-list args)
  (if (null? args)
      args
      (cons (car args) (cadr args))))

(define (handle-number . x)
  (apply (parser-ref 'number) x))

(define (handle-array . args)
  ((parser-ref 'array) (as-list args)))

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

(define (handle-object . args)
  ((parser-ref 'object) (as-list args)))

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

(define handle-string/raw list->string)

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

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

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

(define read-json 
  (let ((read (load-peg "json.peg")))
    (lambda (#!optional (port-or-string (current-input-port)))
      (read port-or-string))))

;; (include "json-grammar.scm")
;; (define read-json (genturfahi json-grammar))

(define char-set:json-unescaped
  (utf8-char-set-union
   (utf8-ucs-range->char-set #x20 #x21)
   (utf8-ucs-range->char-set #x23 #x5B)
   (utf8-ucs-range->char-set #x5D #x7E)
   #;(ucs-range->char-set #x5D #x10FFFF)))

(define (unparse-string s)
  (let ((chars (string->list s)))
    (display #\")
    (for-each
     (lambda (c)
       (if (utf8-char-set-contains? char-set:json-unescaped c)
           (display c)
           (begin
             (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))))

)