(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 char-set:json-escape
  (string->char-set json-escape-chars))

(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-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-2
          utf8-3
          utf8-4))

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

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

(define char
  (any-of (char-seq-match '(: bos (+ (/ #\x20 #\x21
                                        #\x23 #\x5b
                                        #\x5d #\x7f))))
          (none-of* (in char-set:json-special-char) utf8-char)
          (preceded-by (is #\\) (any-of escape unicode fail))))

;; 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:]])+

(define exp '(: ("Ee") (? ("+-")) (+ digit)))


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

(define frac '(: "." (+ digit)))


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

(define int '(or "0" (: ("123456789") (* digit))))


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

(define number
  (bind (char-seq-match `(: bos
                            (? "-")
                            ,int
                            (? ,frac)
                            (? ,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)