; json

; http://json.org for details of json syntax and semantics

; (read-json [port]) reads the next json object on port,
;   which defaults to (current-input-port) if not given,
;   and advances port to next character after json object;
;   returns eof-object if port is exhausted
; (write-json object [port]) writes object as a valid json
;   expression on port, which defaults to (current-output-
;   port) if not given

; object represented as an a-list of (key . value) pairs
; array represented as a vector of elements
; true and false represented as boolean #t and #f
; null represented as the symbol the-json-null-object
; strings represented natively, but unicode not supported
; numbers represented as integers, or as floating point if they
;   contain a decimal point or are specified with e notation

(define json-null (string->symbol "the-json-null-object"))
(define (json-null? obj) (eqv? json-null obj))

(define (read-json . args)
  (let ((port (if (pair? args) (car args) (current-input-port))))

    (define (eat char)
      (let ((c (peek-char port)))
        (if (eof-object? c)
            (error 'read-json "eat unexpected end of file")
            (if (char=? c char) (read-char port)
              (error 'read-json "eat unexpected character")))))

    (define (skip-white-space)
      (let ((c (peek-char port)))
        (if (and (not (eof-object? c)) (char-whitespace? c))
            (begin (eat c) (skip-white-space)))))

    (define (read-member)
      (skip-white-space)
      (let ((key (read-string)))
        (skip-white-space)
        (eat #\:)
        (skip-white-space)
        (let ((val (read-value)))
          (skip-white-space)
          (cons key val))))

    (define (read-object)
      (eat #\{)
      (skip-white-space)
      (let ((c (peek-char port)))
        (if (eof-object? c)
            (error 'read-json "read-object unexpected end of file")
            (if (char=? (peek-char port) #\})
                (begin (eat #\}) (list))
                (let loop ((xs (list (read-member))))
                  (skip-white-space)
                  (let ((c (peek-char port)))
                    (cond ((char=? c #\}) (reverse xs))
                          ((char=? c #\,)
                            (eat #\,)
                            (skip-white-space)
                            (loop (cons (read-member) xs)))
                          (else (error 'read-json "read-object syntax error")))))))))

    (define (read-array)
      (eat #\[)
      (skip-white-space)
      (let ((c (peek-char port)))
        (if (eof-object? c) (error 'read-json "read-array unexpected end of file")
          (if (char=? c #\]) (begin (eat #\]) (vector))
          (let loop ((xs (list (read-value))))
            (skip-white-space)
            (let ((c (peek-char port)))
              (cond ((eof-object? c)
                      (error 'read-json "read-array unexpected end of file"))
                    ((char=? c #\]) (list->vector (reverse xs)))
                    ((char=? c #\,)
                      (eat #\,)
                      (skip-white-space)
                      (loop (cons (read-value) xs)))
                    (else (error 'read-json "read-array syntax error")))))))))

    (define (read-escape)
      (let ((c (peek-char port)))
        (cond ((eof-object? c)
                (error 'read-json "read-escape unexpected end of file"))
              ((char=? c #\\)
                (eat #\\)
                (let ((c (peek-char port)))
                  (cond
                    ((eof-object? c)
                      (error 'read-json "read-escape unexpected end of file"))
                    ((char=? c #\") (read-char port) #\")
                    ((char=? c #\\) (read-char port) #\\)
                    ((char=? c #\/) (read-char port) #\/)
                    ((char=? c #\b) (read-char port) #\backspace)
                    ((char=? c #\f) (read-char port) #\page)
                    ((char=? c #\n) (read-char port) #\newline)
                    ((char=? c #\r) (read-char port) #\return)
                    ((char=? c #\t) (read-char port) #\tab)
                    ((char=? c #\u) (error 'read-json "unicode not supported"))
                    (else (error 'read-json "unrecognized escape sequence")))))
              (else (read-char port)))))

    (define (read-string)
      (eat #\")
      (let loop ((c (peek-char port)) (cs '()))
        (cond ((eof-object? c)
                (error 'read-json "read-string unexpected end of file"))
              ((char=? c #\")
                (eat c) (skip-white-space) (list->string (reverse cs)))
              (else (let ((c (read-escape)))
                      (loop (peek-char port) (cons c cs)))))))

    (define (read-number)
      (define (char->digit c) (- (char->integer c) 48))
      (let* ((sign (let ((c (peek-char port)))
                     (cond ((eof-object? c)
                             (error 'read-json "read-number unexpected end of file"))
                           ((char=? c #\-) (eat #\-)
                             (let ((c (read-char port)))
                               (if (and (not (eof-object? c)) (char-numeric? c)) -1
                                 (error 'read-json "read-number syntax error"))))
                           ((char-numeric? c) 1)
                           (else (error 'read-json "read-number syntax error")))))
             (numb (let loop ((c (peek-char port)) (n 0))
                     (cond ((eof-object? c) n)
                           ((char-numeric? c) (eat c)
                             (loop (peek-char port)
                                   (+ (* n 10) (char->digit c))))
                           (else n))))
             (frac (let ((c (peek-char port)))
                     (if (or (eof-object? c) (not (char=? c #\.))) 0
                       (begin (eat #\.)
                         (let ((c (peek-char port)))
                           (if (or (eof-object? c) (not (char-numeric? c)))
                               (error 'read-json "read-number syntax error")
                               (let loop ((c c) (tens 10) (n 0))
                                 (cond ((eof-object? c) n)
                                       ((char-numeric? c) (eat c)
                                         (loop (peek-char port) (* tens 10)
                                           (+ n (/ (char->digit c) tens))))
                                       (else n)))))))))
             (expo (let ((c (peek-char port)))
                     (if (or (eof-object? c) (not (char-ci=? c #\E))) 0
                       (begin (eat c)
                         (let* ((sign (let ((c (peek-char port)))
                                        (cond ((char=? c #\+) (eat c) 1)
                                              ((char=? c #\-) (eat c) -1)
                                              ((char-numeric? c) 1)
                                              (else (error 'read-json
                                                "read-number syntax error")))))
                                (numb (let loop ((c (peek-char port)) (n 0))
                                        (cond ((eof-object? c) n)
                                              ((char-numeric? c) (eat c)
                                                (loop (peek-char port)
                                                  (+ (* n 10) (char->digit c))))
                                              (else n)))))
                           (* sign numb)))))))

        (if (and (zero? frac) (zero? expo)) (* sign numb)
          (exact->inexact (* sign (+ numb frac) (expt 10 expo))))))

    (define (read-constant)
      (let loop ((c (peek-char port)) (cs '()))
        (if (and (not (eof-object? c)) (char-alphabetic? c))
            (begin (eat c) (loop (peek-char port) (cons c cs)))
            (let ((str (list->string (reverse cs))))
              (cond ((string=? str "true") (skip-white-space) #t)
                    ((string=? str "false") (skip-white-space) #f)
                    ((string=? str "null") (skip-white-space) json-null)
                    (else (error 'read-json "unrecognized constant")))))))

    (define (read-value)
      (skip-white-space)
      (let ((c (peek-char port)))
      (cond ((eof-object? c)
              (error 'read-json "read-value unexpected end of file"))
            ((char=? c #\{) (read-object))
            ((char=? c #\[) (read-array))
            ((char=? c #\") (read-string))
            ((or (char-numeric? c) (char=? c #\-)) (read-number))
            ((char-alphabetic? c) (read-constant))
            (else (error 'read-json "read-value syntax error")))))

    (if (eof-object? (peek-char port)) (read-char port) (read-value))))

(define (write-json val . args)
  (let ((port (if (pair? args) (car args) (current-output-port))))

    (define (write-value val)
      (cond ((json-null? val) (display " null" port))
            ((boolean? val) (display (if val " true" " false") port))
            ((number? val) (display " ") (display (number->string val) port))
            ((string? val) (display " " port) (write val port))
            ((vector? val) (if (zero? (vector-length val)) (display " []" port)
              (begin (display " [") (write-value (vector-ref val 0))
                     (do ((i 1 (+ i 1))) ((= i (vector-length val)))
                       (display " ," port) (write-value (vector-ref val i)))
                     (display " ]" port))))
            ((pair? val) (if (zero? (length val)) (display " {}" port)
              (begin (display " {" port) (write-value (caar val))
                     (display " :" port) (write-value (cdar val))
                     (do ((val (cdr val) (cdr val))) ((null? val))
                       (display " ," port) (write-value (caar val))
                       (display " :" port) (write-value (cdar val)))
                     (display " }" port))))
            (else (error 'write-json "unrecognized"))))

    (write-value val)))

; (string->json str) and (json->str obj) via string ports

(define (string->json str)
  (with-input-from-string str (lambda () (read-json))))

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