(let ()

;; ws <- `[ \t\n\r]*

(define ws
  (zero-or-more (in (string->char-set " \t\n\r"))))

;; begin-array     <- #\[

(define begin-array
  (is #\[))

;; begin-object    <- #\{

(define begin-object
  (is #\{))

;; end-array       <- #\]

(define end-array
  (is #\]))

;; end-object      <- #\}

(define end-object
  (is #\}))

;; name-separator  <- #\:

(define name-separator
  (is #\:))

;; value-separator <- #\,

(define value-separator
  (is #\,))

;; false <- "false" 
;;       -> handle-false

(define false
  (bind (char-seq "false") handle-false))

;; true  <- "true"
;;       -> handle-true

(define true
  (bind (char-seq "true") handle-true))

;; null  <- "null"
;;       -> handle-null

(define null
  (bind (char-seq "null") handle-null))


;; escape  <- ["\\/bfnrt]
;;         -> handle-escape

(define escape
  (bind (in char-set:json-escape)
        handle-escape))

;; unicode <- #\u [[:xdigit:]]{4}
;;         -> handle-unicode

(define unicode
  (bind (as-string
         (preceded-by (is #\u)
                      (repeated (in char-set:hex-digit) 4)))
        (lambda (lead-hex)
          (let ((lead (string->number lead-hex 16)))
            (if (<= #xD800 lead #xDBFF)
              (bind (as-string
                      (preceded-by (char-seq "\\u")
                                   (repeated (in char-set:hex-digit) 4)))
                    (lambda (trail-hex)
                      (let ((trail (string->number trail-hex 16)))
                        (if (<= #xDC00 trail #xDFFF)
                          (handle-unicode
                            (+ #x010000
                               (bitwise-ior
                                 (arithmetic-shift (- lead #xD800) 10)
                                 (- trail #xDC00))))
                          fail))))
              (if (<= #xDC00 lead #xDFFF)
                fail
                (handle-unicode lead)))))))

(define (ucs-range->char-set/inclusive lower upper)
  (ucs-range->char-set lower (add1 upper)))

(define utf8-tail
  (in (ucs-range->char-set/inclusive #x80 #xBF)))

(define utf8-1
  (in (ucs-range->char-set/inclusive #x00 #x7F)))

(define utf8-2
  (sequence
    (in (ucs-range->char-set/inclusive #xC2 #xDF))
    utf8-tail))

(define utf8-3
  (any-of
    (sequence
      (is #\xE0)
      (in (ucs-range->char-set/inclusive #xA0 #xBF))
      utf8-tail)
    (sequence
      (in (ucs-range->char-set/inclusive #xE1 #xEC))
      (repeated utf8-tail 2))
    (sequence
      (is #\xED)
      (in (ucs-range->char-set/inclusive #x80 #x9F))
      utf8-tail)
    (sequence
      (in (ucs-range->char-set/inclusive  #xEE #xEF))
      (repeated utf8-tail 2))))

(define utf8-4
  (any-of
    (sequence
      (is #\xF0)
      (in (ucs-range->char-set/inclusive #x90 #xBF))
      (repeated utf8-tail 2))
    (sequence
      (in (ucs-range->char-set/inclusive #xF1 #xF3))
      (repeated utf8-tail 3))
    (sequence
      (is #\xF4)
      (in (ucs-range->char-set/inclusive #x80 #x8F))
      (repeated utf8-tail 2))))

(define utf8-char
  (any-of
    utf8-1
    utf8-2
    utf8-3
    utf8-4))

;; char    <- #\\ ( escape / unicode ) / (![[:cntrl:]"\\] .)

(define char
  (any-of (preceded-by (is #\\) (any-of escape unicode fail))
          (none-of* (in char-set:json-char) utf8-char)))

;; raw-string <- #\" char* #\"
;;            -> handle-string/raw

(define raw-string
  (memoize
   (as-string
    (enclosed-by (is #\")
                 (zero-or-more char)
                 (is #\")))))

;; member <- ws raw-string ws name-separator value
;;        -> handle-member

(define member
  (recursive-parser
   (sequence* ((_ ws)
               (name raw-string)
               (_ (preceded-by ws name-separator))
               (value value))
     (handle-member name value))))


;; object <- begin-object ws ( member ( value-separator member )* )? end-object
;;        -> handle-object

(define object
  (bind (enclosed-by
         (preceded-by begin-object ws)
         (any-of
          (sequence*
              ((first-member (member))
               (more-members (zero-or-more (preceded-by value-separator (member)))))
            (result (cons first-member more-members)))
          (result '()))
         end-object)
        handle-object))

;; array  <- begin-array ws ( value ( value-separator value )* )? end-array
;;        -> handle-array


(define array
  (recursive-parser
   (bind (enclosed-by
          (preceded-by begin-array ws)
          (any-of
           (sequence*
               ((first-value value)
                (more-values (zero-or-more (preceded-by value-separator value))))
             (result (cons first-value more-values)))
           (result '()))
          end-array)
         handle-array)))

;; exp    <- [Ee] ([+-])? ([[:digit:]])+
;;        -> as-string

(define exp
  (as-string
   (sequence* ((e      (in #\E #\e))
               (sig    (maybe (in #\+ #\-)))
               (digits (one-or-more (in char-set:digit))))
     (result (cons* e sig digits)))))

;; frac   <- ,#\. ([[:digit:]])+
;;        -> as-string

(define frac
  (as-string
   (sequence* ((dec (is #\.))
               (digits (one-or-more (in char-set:digit))))
     (result (cons dec digits)))))

;; int    <- ,"0" / ( [123456789] ([[:digit:]])* )
;;        -> as-string

(define int
  (any-of (char-seq "0")
          (as-string
           (sequence*
               ((n  (in (string->char-set "123456789")))
                (ns (zero-or-more (in char-set:digit))))
             (result (cons n ns))))))

;; number <- ,"-"? int frac? exp?
;;        -> handle-number

(define number
  (bind (as-string
         (sequence (maybe (is #\-))
                   int
                   (maybe frac)
                   (maybe exp)))
        handle-number))

;; string  <- raw-string
;;         -> handle-string

(define string
  (bind raw-string handle-string))

;; value  <- ws ( null / false / true / object / array / number / string ) ws

(define value
  (enclosed-by ws (any-of null false true object (array) number string) ws))

(define (trailing-ws input)
  (if (consume-trailing-whitespace?)
      (ws input)
      (cons #f input)))

;; document <- ws ( object / array ) ws

(define document
  (enclosed-by ws (any-of object (array)) trailing-ws))

document)