(define (pk . args)
  (write args)
  (newline)
  (car (reverse args)))

(define json-number-of-character-limit (make-parameter +inf.0))

(define json-nesting-depth-limit (make-parameter +inf.0))

(define (json-null? obj)
  (eq? obj 'null))

(define-record-type <json-error>
  (make-json-error reason)
  json-error?
  (reason json-error-reason))

(define (json-whitespace? char)
  (case char
    ((#\x20 ; Space
      #\x09 ; Horizontal tab
      #\x0A ; Line feed or New line
      #\x0D
      #\x1E  ;; Record Separator
      )
     #t)
    (else #f)))

(define (expect value other)
  (when (eof-object? value)
    (raise (make-json-error "Unexpected end-of-file.")))
  (assume (and (char? value) (char? other)) "invalid argument" '%json-tokens expect value other)
  (unless (char=? value other)
    (raise (make-json-error "Unexpected character."))))

(define (port->generator port)
  (let ((count 0)
        (limit (json-number-of-character-limit)))
    (lambda ()
      (let ((out (guard (ex ((%read-error? ex) (raise (make-json-error "Read error!"))))
                   (read-char port))))
        (if (= count limit)
            (raise (make-json-error "Maximum number of character reached."))
            (begin
              (set! count (+ count 1))
              out))))))

(define (gcons head generator)
  ;; returns a generator that will yield, HEAD the first time, and
  ;; after than, it will yield items from GENERATOR.
  (let ((head? #t))
    (lambda ()
      (if head?
          (begin (set! head? #f) head)
          (generator)))))

(define (%json-tokens generator)

  (define (maybe-ignore-whitespace generator)
    (let loop ((char (generator)))
      (if (json-whitespace? char)
          (loop (generator))
          char)))

  (define (expect-null generator)
    (expect (generator) #\u)
    (expect (generator) #\l)
    (expect (generator) #\l))

  (define (expect-true generator)
    (expect (generator) #\r)
    (expect (generator) #\u)
    (expect (generator) #\e))

  (define (expect-false generator)
    (expect (generator) #\a)
    (expect (generator) #\l)
    (expect (generator) #\s)
    (expect (generator) #\e))

  (define (maybe-char generator)
    (let ((char (generator)))
      (when (eof-object? char)
        (raise (make-json-error "Unexpected end-of-file.")))
      (when (char=? char #\")
        (raise (make-json-error "Unexpected end of string.")))
      char))

  (define (read-unicode-escape generator)
    (let* ((one (maybe-char generator))
           (two (maybe-char generator))
           (three (maybe-char generator))
           (four (maybe-char generator)))
      (let ((out (string->number (list->string (list one two three four)) 16)))
        (if out
            out
            (raise (make-json-error "Invalid code point."))))))

  (cond-expand
   (gambit (define ash ##arithmetic-shift))
   (else (define ash arithmetic-shift)))

  (define (read-json-string generator)
    (let loop ((char (generator))
               (out '()))

      (when (eof-object? char)
        (raise (make-json-error "Unexpected end of file.")))

      (when (or (char=? char #\x00)
                (char=? char #\newline)
                (char=? char #\tab))
        (raise (make-json-error "Unescaped control char.")))

      ;; XXX: Here be dragons.
      (if (char=? char #\\)
          (begin
            (let loop-unescape ((char (generator))
                                (chars-unescaped '()))
              (case char
                ((#\" #\\ #\/) (loop (generator)
                                     (cons char (append chars-unescaped
                                                        out))))
                ((#\b) (loop (generator) (cons #\backspace
                                                    (append chars-unescaped
                                                            out))))
                ((#\f) (loop (generator) (cons #\x0C
                                                    (append chars-unescaped
                                                            out))))
                ((#\n) (loop (generator) (cons #\newline
                                                    (append chars-unescaped
                                                            out))))
                ((#\r) (loop (generator) (cons #\x0D
                                                    (append chars-unescaped
                                                            out))))
                ((#\t) (loop (generator) (cons #\tab
                                                    (append chars-unescaped
                                                            out))))
                ((#\u) (let loop-unicode ((code1 (read-unicode-escape generator))
                                          (chars chars-unescaped))
                         (let ((next-char (generator)))
                           (if (and (<= #xd800 code1 #xdbff)
                                    (char=? next-char #\\))
                               (if (char=? (generator) #\u)
                                   (let ((code2 (read-unicode-escape generator)))
                                     (if (<= #xdc00 code2 #xdfff)
                                         (let ((integer
                                                (+ #x10000 (bitwise-ior
                                                            (ash (- code1 #xd800) 10)
                                                            (- code2 #xdc00)))))
                                           ;; full escape of unicode is parsed...
                                           (loop (generator)
                                                 (cons (integer->char integer)
                                                       (append chars
                                                               out))))
                                         ;; This is another unicode char
                                         (loop-unicode (read-unicode-escape generator)
                                                       (cons (integer->char code1) chars))))
                                   ;; The escaped unicode char is
                                   ;; parsed, need to parse another
                                   ;; escape that is not a unicode
                                   ;; escape sequence
                                   (loop-unescape char (cons (integer->char code1)
                                                             chars)))
                             ;; This is not a big-ish unicode char and
                             ;; the next thing is some other char.
                             (loop next-char
                                   (cons (integer->char code1) (append chars out)))))))
                (else (raise (make-json-error "Unexpected escaped sequence."))))))
          (cond
           ((char=? char #\")
            (list->string (reverse out)))
           (else
            (loop (generator) (cons char out)))))))

  (define (maybe-read-number generator)
    ;; accumulate chars until a control char or whitespace is reached,
    ;; validate that it is JSON number, then intrepret it as Scheme
    ;; number using string->number
    (let loop ((char (generator))
               (out '()))
      (if (or (eof-object? char)
              (json-whitespace? char)
              (char=? char #\,)
              (char=? char #\])
              (char=? char #\}))
          (let ((string (list->string (reverse out))))
            (if (valid-number? string)
                (let ((number (string->number string)))
                  (if number
                      (values number char)
                      (raise (make-json-error "Invalid number."))))
                (raise (make-json-error "Invalid number."))))
          (loop (generator) (cons char out)))))

  ;; gist
  (assume (procedure? generator) "invalid argument" generator)

  (let ((char (generator)))
    (if (eof-object? char)
        eof-object  ;; return an empty generator
        (begin

          (unless (char=? char #\xFEFF)
            ;; if it is not a UTF-8 BOM, put back the char in front of
            ;; the generator
            (set! generator (gcons char generator)))

          (lambda ()

            (define char (maybe-ignore-whitespace generator))

            (if (eof-object? char)
                char ;; return that eof-object
                (case char
                  ((#\n) (expect-null generator) 'null)
                  ((#\t) (expect-true generator) #t)
                  ((#\f) (expect-false generator) #f)
                  ((#\:) 'colon)
                  ((#\,) 'comma)
                  ((#\[) 'array-start)
                  ((#\]) 'array-end)
                  ((#\{) 'object-start)
                  ((#\}) 'object-end)
                  ((#\") (read-json-string generator))
                  (else
                   (call-with-values (lambda () (maybe-read-number (gcons char generator)))
                     (lambda (number next)
                       (set! generator (gcons next generator))
                       number))))))))))

(define json-tokens
  (case-lambda
   (() (json-tokens (current-input-port)))
   ((port-or-generator)
    (cond
     ((procedure? port-or-generator)
      (%json-tokens port-or-generator))
     ((and (textual-port? port-or-generator) (input-port? port-or-generator))
       (%json-generator (port->generator port-or-generator)))
     (else (error 'json "json-tokens error, argument is not valid" port-or-generator))))))

(define (%json-generator tokens)

  (define limit (json-nesting-depth-limit))
  (define count 0)

  (define (handle-limit!)
    (if (= count limit)
        (raise (make-json-error "Maximum JSON nesting depth reached"))
        (set! count (+ count 1))))

  (define (array-maybe-continue tokens k)
    (lambda ()
      (let ((token (tokens)))
        (case token
          ((comma) (start tokens (array-maybe-continue tokens k)))
          ((array-end) (values 'array-end k))
          (else (raise (make-json-error "Invalid array, expected comma or array close.")))))))

  (define (array-start tokens k)
    (lambda ()
      (handle-limit!)
      (let ((token (tokens)))
        (if (eq? token 'array-end)
            (values 'array-end k)
            (start (gcons token tokens) (array-maybe-continue tokens k))))))

  (define (object-maybe-continue tokens k)
    (lambda ()
      (let ((token (tokens)))
        (case token
          ((object-end) (values 'object-end k))
          ((comma) (let ((token (tokens)))
                     (unless (string? token)
                       (raise (make-json-error "Invalid object, expected an object key")))
                     (values token
                             (object-colon tokens k))))
          (else (raise (make-json-error "Invalid object, expected comma or object close.")))))))

  (define (object-colon tokens k)
    (lambda ()
      (let ((token (tokens)))
        (if (eq? token 'colon)
            (let ((token (tokens)))
              (if (eof-object? token)
                  (raise (make-json-error "Invalid object, expected object value."))
                  (start (gcons token tokens) (object-maybe-continue tokens k))))
            (raise (make-json-error "Invalid object, expected colon."))))))

  (define (object-start tokens k)
    (lambda ()
      (handle-limit!)
      (let ((token (tokens)))
        (cond
         ((eq? token 'object-end) (values 'object-end k))
         ((string? token)
          (values token
                  (object-colon tokens k)))
         (else (raise (make-json-error "Invalid object, expected object key or object close.")))))))

  (define (start tokens k)
    (let ((token (tokens)))
      (if (eof-object? token)
          (values token k)
          (cond
           ((or (json-null? token)
                (number? token)
                (string? token)
                (boolean? token))
            (values token k))
           ((eq? token 'array-start)
            (values 'array-start (array-start tokens k)))
           ((eq? token 'object-start)
            (values 'object-start (object-start tokens k)))
           (else (raise (make-json-error "Is it JSON text?!")))))))

  (define (end-of-top-level-value)
    ;; json-generator returns a generator that reads one top-level
    ;; json. If there is more than one top-level json value in the
    ;; generator separated with space as it is the case of json-lines,
    ;; you need to call json-generator with the same port or
    ;; generator.
    (values (eof-object) #f))

  (define (make-trampoline-generator tokens)
    (let ((continuation (lambda () (start tokens end-of-top-level-value))))
      (lambda ()
        (when continuation
          (call-with-values continuation
            (lambda (event new-continuation)
              (set! continuation new-continuation)
              event))))))

  ;; gist

  (assume (procedure? tokens) "invalid argument" %json-generator tokens)

  (make-trampoline-generator tokens))

(define json-generator-error
  "Argument does not look like a generator and is not a textual input port.")

(define json-generator
  (case-lambda
    (() (json-generator (current-input-port)))
    ((port)
     (%json-generator (json-tokens (port->generator port))))))

;; XXX: procedure foldts is not used as-is. It was copied here for
;; documentation purpose (public domain, by Oleg Kiselyov).
(define (foldts fdown fup fhere seed tree)
  ;; - fhere is applied to the leafs of the tree
  ;;
  ;; - fdown is invoked when a non-leaf node is entered before any of
  ;; the node's children are visited. fdown action has to generate a
  ;; seed to be passed to the first visited child of the node.
  ;;
  ;; - fup is invoked after all the children of a node have been
  ;; seen. The first argument is the local state at the moment the
  ;; traversal process enters the branch rooted at the current node. The
  ;; second argument is the result of visiting all child branches.  The
  ;; action of fup isto produce a seed that is taken to be the state of
  ;; the traversal after the process leave the currents the current
  ;; branch.
  (cond
   ((null? tree) seed)
   ((not (pair? tree))      ; An atom
    (fhere seed tree))
   (else
    (let loop ((kid-seed (fdown seed tree))
               (kids (cdr tree)))
      (if (null? kids)
          (fup seed kid-seed tree)
          (loop (foldts fdown fup fhere kid-seed (car kids))
                (cdr kids)))))))

(define (%json-fold proc array-start array-end object-start object-end seed port-or-generator)

  ;; json-fold is inspired from the above foldts definition, unlike
  ;; the above definition, it is continuation-passing-style.  fhere is
  ;; renamed PROC.  Unlike foldts, json-fold will call (proc obj seed)
  ;; everytime a JSON value or complete structure is read from the
  ;; EVENTS generator, where OBJ will be: a) In the case of
  ;; structures, the the result of the recursive call or b) a JSON
  ;; value.

  ;; json-fold will terminates in three cases:
  ;;
  ;; - eof-object was generated, return the seed.
  ;;
  ;; - event-type 'array-end is generated, if EVENTS is returned by
  ;; json-generator, it means a complete array was read.
  ;;
  ;; - event-type 'object-end is generated, similarly, if EVENTS is
  ;; returned by json-generator, it means complete array was
  ;; read.
  ;;
  ;; IF EVENTS does not follow the json-generator protocol, the
  ;; behavior is unspecified.

  (define events (json-generator port-or-generator))

  (define (ruse seed k)
    (lambda ()
      (let loop ((seed seed))
        (let ((event (events)))
          (if (eof-object? event)
              (begin (k seed) #f)
              (case event
                ;; termination cases
                ((array-end) (k seed))
                ((object-end) (k seed))
                ;; recursion
                ((array-start) (ruse (array-start seed)
                                     (lambda (out) (loop (proc (array-end out) seed)))))
                ((object-start) (ruse (object-start seed)
                                      (lambda (out) (loop (proc (object-end out) seed)))))
                (else (loop (proc event seed)))))))))

  (define (make-trampoline-fold k)
    (let ((thunk (ruse seed k)))
      (let loop ((thunk thunk))
        (when thunk
          (loop (thunk))))))

  (define %unset '(unset))

  (let ((out %unset))
    (define (escape out*)
      (set! out out*)
      #f)
    (make-trampoline-fold escape)
    (if (eq? out %unset)
        (error 'json "Is this JSON text")
        out)))

(define json-fold
  (case-lambda
   ((proc array-start array-end object-start object-end seed)
    (json-fold proc array-start array-end object-start object-end seed (current-input-port)))
   ((proc array-start array-end object-start object-end seed port-or-generator)
    (%json-fold proc array-start array-end object-start object-end seed port-or-generator))))

(define (%json-read port-or-generator)

  (define %root '(root))

  (define (array-start seed)
    ;; array will be read as a list, then converted into a vector in
    ;; array-end.
    '())

  (define (array-end items)
    (list->vector (reverse items)))

  (define (object-start seed)
    ;; object will be read as a property list, then converted into an
    ;; alist in object-end.
    '())

  (define (plist->alist plist)
    ;; PLIST is a list of even items, otherwise json-generator
    ;; would have raised a json-error.
    (let loop ((plist plist)
               (out '()))
      (if (null? plist)
          out
          (loop (cddr plist) (cons (cons (string->symbol (cadr plist)) (car plist)) out)))))

  (define object-end plist->alist)

  (define (proc obj seed)
    ;; proc is called when a JSON value or structure was completly
    ;; read.  The parse result is passed as OBJ.  In the case where
    ;; what is parsed is a JSON simple json value then OBJ is simply
    ;; the token that is read that can be 'null, a number or a string.
    ;; In the case where what is parsed is a JSON structure, OBJ is
    ;; what is returned by OBJECT-END or ARRAY-END.
    (if (eq? seed %root)
     ;; It is toplevel, a complete JSON value or structure was read,
     ;; return it.
     obj
     ;; This is not toplevel, hence json-fold is called recursivly,
     ;; to parse an array or object.  Both ARRAY-START and
     ;; OBJECT-START return an empty list as a seed to serve as an
     ;; accumulator.  Both OBJECT-END and ARRAY-END expect a list
     ;; as argument.
     (cons obj seed)))

  (let ((out (json-fold proc
                        array-start
                        array-end
                        object-start
                        object-end
                        %root
                        port-or-generator)))
    ;; if out is the root object, then the port or generator is empty.
    (if (eq? out %root)
        (eof-object)
        out)))

(define json-read
  (case-lambda
    (() (json-read (current-input-port)))
    ((port-or-generator) (%json-read port-or-generator))))

;; json-lines-read

(define json-lines-read
  (case-lambda
    (() (json-lines-read (current-input-port)))
    ((port-or-generator)
     (lambda ()
       (json-read port-or-generator)))))

;; json-sequence-read

(define json-sequence-read
  (case-lambda
    (() (json-sequence-read (current-input-port)))
    ((port-or-generator)
     (lambda ()
       (let loop ()
         (guard (ex ((json-error? ex) (loop)))
           (json-read port-or-generator)))))))

;; write procedures

(define (json-accumulator accumulator)

  (define (write-json-char char accumulator)
    (case char
      ((#\x00) (accumulator "\\u0000"))
      ((#\") (accumulator "\\\""))
      ((#\\) (accumulator "\\\\"))
      ((#\/) (accumulator "\\/"))
      ((#\return) (accumulator "\\r"))
      ((#\newline) (accumulator "\\n"))
      ((#\tab) (accumulator "\\t"))
      ((#\backspace) (accumulator "\\b"))
      ((#\x0c) (accumulator "\\f"))
      ;;((#\x0d) (accumulator "\\r"))
      (else (accumulator char))))

  (define (write-json-string string accumulator)
    (accumulator #\")
    (string-for-each
     (lambda (char) (write-json-char char accumulator))
     string)
    (accumulator #\"))

  (define (write-json-value obj accumulator)
    (cond
     ((eq? obj 'null) (accumulator "null"))
     ((boolean? obj) (if obj
                         (accumulator "true")
                         (accumulator "false")))
     ((string? obj) (write-json-string obj accumulator))
     ((number? obj) (accumulator (number->string obj)))
     (else (raise (make-json-error "Invalid json value.")))))

  (define (raise-invalid-event event)
    (raise event))
  ;;(raise (make-json-error "json-accumulator: invalid event.")))

  (define (object-start k)
    (lambda (accumulator event)
      (accumulator #\{)
      (case (car event)
        ((json-value)
         (let ((key (cdr event)))
           (unless (symbol? key) (raise-invalid-event event))
           (write-json-string (symbol->string key) accumulator)
           (object-value k)))
        ((json-structure)
         (case (cdr event)
           ((object-end)
            (accumulator #\})
            k)
           (else (raise-invalid-event event))))
        (else (raise-invalid-event event)))))

  (define (object-value k)
    (lambda (accumulator event)
      (accumulator #\:)
      (case (car event)
        ((json-value)
         (write-json-value (cdr event) accumulator)
         (object-maybe-continue k))
        ((json-structure)
         (case (cdr event)
           ((array-start)
            (array-start (object-maybe-continue k)))
           ((object-start)
            (object-start (object-maybe-continue k)))
           (else (raise-invalid-event event))))
        (else (raise-invalid-event event)))))

  (define (object-maybe-continue k)
    (lambda (accumulator event)
      (case (car event)
        ((json-value)
         (accumulator #\,)
         (let ((key (cdr event)))
           (unless (symbol? key) (raise-invalid-event event))
           (write-json-value (symbol->string key) accumulator)
           (object-value k)))
        ((json-structure)
         (case (cdr event)
           ((object-end)
            (accumulator #\})
            k)
           (else (raise-invalid-event event))))
        (else (raise-invalid-event event)))))

  (define (array-start k)
    (lambda (accumulator event)
      (accumulator #\[)
      (case (car event)
        ((json-value)
         (write-json-value (cdr event) accumulator)
         (array-maybe-continue k))
        ((json-structure)
         (case (cdr event)
           ((array-end)
            (accumulator #\])
            k)
           ((array-start) (array-start (array-maybe-continue k)))
           ((object-start) (object-start (array-maybe-continue k)))
           (else (raise-invalid-event event))))
        (else (raise-invalid-event event)))))

  (define (array-maybe-continue k)
    (lambda (accumulator event)
      (case (car event)
        ((json-value)
         (accumulator #\,)
         (write-json-value (cdr event) accumulator)
         (array-maybe-continue k))
        ((json-structure)
         (case (cdr event)
           ((array-end)
            (accumulator #\])
            k)
           ((array-start)
            (accumulator #\,)
            (array-start (array-maybe-continue k)))
           ((object-start)
            (accumulator #\,)
            (object-start (array-maybe-continue k)))
           (else (raise-invalid-event event))))
        (else (raise-invalid-event event)))))

  (define (start accumulator event)
    (case (car event)
      ((json-value)
       (write-json-value (cdr event) accumulator)
       raise-invalid-event)
      ((json-structure)
       (case (cdr event)
         ((array-start)
          (array-start raise-invalid-event))
         ((object-start)
          (object-start raise-invalid-event))
         (else (raise-invalid-event event))))
      (else (raise-invalid-event event))))

  (assume (procedure? accumulator)
          "ACCUMULATOR does look like a valid accumulator.")

  (let ((k start))
    (lambda (event)
      (set! k (k accumulator event)))))

(define (%json-write obj accumulator)

  (define (void)
    (if #f #f))

  (define (raise-unless-valid? obj)
    (cond
     ((null? obj) (void))
     ((eq? obj 'null) (void))
     ((boolean? obj) (void))
     ((string? obj) (void))
     ((and (number? obj)
           (not (infinite? obj))
           (not (nan? obj))
           (real? obj)
           (or (and (exact? obj) (= (denominator obj) 1))
               (inexact? obj)))
      (void))
     ((vector? obj)
      (vector-for-each (lambda (obj) (raise-unless-valid? obj)) obj))
     ;; XXX: use pair? then recursively check the tail.
     ((pair? obj)
      (for-each (lambda (obj)
                  (unless (pair? obj)
                    (raise (make-json-error "Unexpected object, not a pair.")))
                  (unless (symbol? (car obj))
                    (raise (make-json-error "Unexpected object, not a symbol key.")))
                  (raise-unless-valid? (cdr obj)))
                obj))
     (else (raise (make-json-error "Unexpected object")))))

  (define (write obj accumulator)
    (cond
     ((or (eq? obj 'null)
          (boolean? obj)
          (string? obj)
          (symbol? obj)
          (number? obj))
      (accumulator (cons 'json-value obj)))
     ((vector? obj)
      (accumulator '(json-structure . array-start))
      (vector-for-each (lambda (obj) (write obj accumulator)) obj)
      (accumulator '(json-structure . array-end)))
     ((null? obj)
      (accumulator '(json-structure . object-start))
      (accumulator '(json-structure . object-end)))
     ((pair? obj)
      (accumulator '(json-structure . object-start))
      (for-each (lambda (pair)
                  (write (car pair) accumulator)
                  (write (cdr pair) accumulator))
                obj)
      (accumulator '(json-structure . object-end)))
     (else (error "Unexpected error!"))))

  (assume (procedure? accumulator)
          "ACCUMULATOR does look like a valid accumulator.")
  (raise-unless-valid? obj)
  (write obj (json-accumulator accumulator)))

(define (port->accumulator port)
  (lambda (char-or-string)
    (cond
     ((char? char-or-string) (write-char char-or-string port))
     ((string? char-or-string) (write-string char-or-string port))
     (else (raise (make-json-error "Not a char or string"))))))

(define json-write
  (case-lambda
    ((obj) (json-write obj (current-output-port)))
    ((obj port-or-accumulator)
     (assume (or (procedure? port-or-accumulator)
                  (and (textual-port? port-or-accumulator)
                       (output-port? port-or-accumulator)))
          "ACCUMULATOR does look like a valid accumulator.")
     (if (procedure? port-or-accumulator)
         (%json-write obj port-or-accumulator)
         (%json-write obj (port->accumulator port-or-accumulator))))))

(define (%read-error? x)
  (read-error? x))
(define (valid-number? string)
  (number? (string->number string)))