;;; Strict JSON reader shared by the S7-backed Dat application layer.
;;; Objects become (json:object ("key" . value) ...), arrays become
;;; (json:array value ...), and JSON null is the symbol json:null.

(define (json:codepoint->utf8 code)
  (if (<= code #x7f)
      (list (integer->char code))
      (if (<= code #x7ff)
          (list
           (integer->char (+ #xc0 (quotient code 64)))
           (integer->char (+ #x80 (modulo code 64))))
          (if (<= code #xffff)
              (list
               (integer->char (+ #xe0 (quotient code 4096)))
               (integer->char (+ #x80 (modulo (quotient code 64) 64)))
               (integer->char (+ #x80 (modulo code 64))))
              (list
               (integer->char (+ #xf0 (quotient code 262144)))
               (integer->char (+ #x80 (modulo (quotient code 4096) 64)))
               (integer->char (+ #x80 (modulo (quotient code 64) 64)))
               (integer->char (+ #x80 (modulo code 64))))))))

(define (dat:json-parse source)
  (if (not (string? source))
      (error 'wrong-type-arg "dat:json-parse expects a string" source))
  (let ((port (open-input-string source)))
    (define (fail message)
      (error 'json-parse-error message))
    (define (peek) (peek-char port))
    (define (take) (read-char port))
    (define (ws?)
      (let ((c (peek)))
        (and (char? c)
             (or (char=? c #\space) (char=? c #\tab)
                 (char=? c #\newline) (char=? c #\return)))))
    (define (skip-ws)
      (do () ((not (ws?))) (take)))
    (define (expect character)
      (if (or (not (char? (peek))) (not (char=? (take) character)))
          (fail (string-append "expected " (string character)))))
    (define (hex-value c)
      (cond ((and (char>=? c #\0) (char<=? c #\9))
             (- (char->integer c) (char->integer #\0)))
            ((and (char>=? c #\a) (char<=? c #\f))
             (+ 10 (- (char->integer c) (char->integer #\a))))
            ((and (char>=? c #\A) (char<=? c #\F))
             (+ 10 (- (char->integer c) (char->integer #\A))))
            (else (fail "invalid hexadecimal escape"))))
    (define (hex4)
      (let loop ((left 4) (value 0))
        (if (= left 0) value
            (let ((c (take)))
              (if (not (char? c)) (fail "incomplete unicode escape"))
              (loop (- left 1) (+ (* value 16) (hex-value c)))))))
    (define (parse-string)
      (expect #\")
      (let loop ((reversed '()))
        (let ((c (take)))
          (cond ((not (char? c)) (fail "unterminated string"))
                ((char=? c #\") (list->string (reverse reversed)))
                ((char=? c #\\)
                 (let ((escape (take)))
                   (cond ((not (char? escape)) (fail "incomplete escape"))
                         ((char=? escape #\") (loop (cons #\" reversed)))
                         ((char=? escape #\\) (loop (cons #\\ reversed)))
                         ((char=? escape #\/) (loop (cons #\/ reversed)))
                         ((char=? escape #\b) (loop (cons (integer->char 8) reversed)))
                         ((char=? escape #\f) (loop (cons (integer->char 12) reversed)))
                         ((char=? escape #\n) (loop (cons #\newline reversed)))
                         ((char=? escape #\r) (loop (cons #\return reversed)))
                         ((char=? escape #\t) (loop (cons #\tab reversed)))
                         ((char=? escape #\u)
                          (let* ((first (hex4))
                                 (code
                                  (cond ((and (>= first #xd800) (<= first #xdbff))
                                         (expect #\\) (expect #\u)
                                         (let ((second (hex4)))
                                           (if (or (< second #xdc00) (> second #xdfff))
                                               (fail "invalid unicode surrogate pair"))
                                           (+ #x10000 (* (- first #xd800) #x400)
                                              (- second #xdc00))))
                                        ((and (>= first #xdc00) (<= first #xdfff))
                                         (fail "unpaired unicode low surrogate"))
                                        (else first))))
                            (if (< code 32) (fail "invalid control character escape"))
                            (loop (append (reverse (json:codepoint->utf8 code))
                                          reversed))))
                         (else (fail "invalid string escape")))))
                ((< (char->integer c) 32) (fail "unescaped control character"))
                (else (loop (cons c reversed)))))))
    (define (digit? c)
      (and (char? c) (char>=? c #\0) (char<=? c #\9)))
    (define (parse-number)
      (let loop ((chars '()))
        (let ((c (peek)))
          (if (and (char? c)
                   (or (digit? c) (memv c '(#\- #\+ #\. #\e #\E))))
              (begin (take) (loop (cons c chars)))
              (let* ((text (list->string (reverse chars)))
                     (number (string->number text)))
                (if (or (string=? text "") (not number)
                        (not (json:number-token? text)))
                    (fail "invalid JSON number"))
                number)))))
    (define (parse-array)
      (expect #\[)
      (skip-ws)
      (if (and (char? (peek)) (char=? (peek) #\]))
          (begin (take) '(json:array))
          (let loop ((values '()))
            (let ((value (parse-value)))
              (skip-ws)
              (cond ((and (char? (peek)) (char=? (peek) #\]))
                     (take) (cons 'json:array (reverse (cons value values))))
                    ((and (char? (peek)) (char=? (peek) #\,))
                     (take) (skip-ws) (loop (cons value values)))
                    (else (fail "expected comma or closing bracket")))))))
    (define (parse-object)
      (expect #\{)
      (skip-ws)
      (if (and (char? (peek)) (char=? (peek) #\}))
          (begin (take) '(json:object))
          (let loop ((fields '()))
            (if (or (not (char? (peek))) (not (char=? (peek) #\")))
                (fail "object key must be a string"))
            (let ((key (parse-string)))
              (skip-ws) (expect #\:) (skip-ws)
              (let ((field (cons key (parse-value))))
                (skip-ws)
                (cond ((and (char? (peek)) (char=? (peek) #\}))
                       (take) (cons 'json:object (reverse (cons field fields))))
                      ((and (char? (peek)) (char=? (peek) #\,))
                       (take) (skip-ws) (loop (cons field fields)))
                      (else (fail "expected comma or closing brace"))))))))
    (define (literal token value)
      (for-each (lambda (expected)
                  (if (or (not (char? (peek)))
                          (not (char=? (take) expected)))
                      (fail "invalid JSON literal")))
                (string->list token))
      value)
    (define (parse-value)
      (skip-ws)
      (let ((c (peek)))
        (cond ((not (char? c)) (fail "expected a JSON value"))
              ((char=? c #\") (parse-string))
              ((char=? c #\{) (parse-object))
              ((char=? c #\[) (parse-array))
              ((char=? c #\t) (literal "true" #t))
              ((char=? c #\f) (literal "false" #f))
              ((char=? c #\n) (literal "null" 'json:null))
              ((or (digit? c) (char=? c #\-)) (parse-number))
              (else (fail "unexpected character in JSON")))))
    (let ((value (parse-value)))
      (skip-ws)
      (if (not (eof-object? (peek))) (fail "trailing data after JSON value"))
      value)))

;;; Validate the RFC 8259 number grammar before string->number, which accepts
;;; Scheme-specific forms that are not valid JSON.
(define (json:number-token? text)
  (let* ((n (string-length text)) (i 0))
    (define (at c) (and (< i n) (char=? (string-ref text i) c)))
    (define (digits)
      (let ((start i))
        (do () ((or (>= i n)
                    (not (char<=? #\0 (string-ref text i) #\9))))
          (set! i (+ i 1)))
        (> i start)))
    (if (at #\-) (set! i (+ i 1)))
    (let ((integer-ok
           (cond ((at #\0) (set! i (+ i 1)) (not (and (< i n) (char<=? #\0 (string-ref text i) #\9))))
                 (else (and (< i n) (char<=? #\1 (string-ref text i) #\9)
                            (begin (set! i (+ i 1)) (digits) #t))))))
      (and integer-ok
           (or (not (at #\.))
               (begin (set! i (+ i 1)) (digits)))
           (or (not (or (at #\e) (at #\E)))
               (begin (set! i (+ i 1))
                      (if (or (at #\+) (at #\-)) (set! i (+ i 1)))
                      (digits)))
           (= i n)))))

(define (dat:json-object-ref object key . fallback)
  (if (or (not (pair? object)) (not (eq? (car object) 'json:object)))
      (error 'wrong-type-arg "expected a parsed JSON object" object)
      (let ((field (assoc key (cdr object))))
        (if field (cdr field) (if (pair? fallback) (car fallback) #f)))))

;;; Encode the same tagged values returned by dat:json-parse. Scheme records
;;; remain the native representation; this is the narrow adapter used when a
;;; compatible peer requires JSON bytes on the wire.
(define (dat:json-stringify value)
  (define (write-unicode-escape n port)
    (let ((digits "0123456789abcdef"))
      (display "\\u" port)
      (for-each
       (lambda (shift)
         (write-char (string-ref digits (modulo (quotient n shift) 16)) port))
       '(4096 256 16 1))))
  (define (string-encode text)
    (let ((port (open-output-string)))
      (write-char #\" port)
      (for-each
       (lambda (c)
         (let ((n (char->integer c)))
           (cond ((char=? c #\") (display "\\\"" port))
                 ((char=? c #\\) (display "\\\\" port))
                 ((char=? c #\backspace) (display "\\b" port))
                 ((char=? c #\newline) (display "\\n" port))
                 ((char=? c #\return) (display "\\r" port))
                 ((char=? c #\tab) (display "\\t" port))
                 ((< n 32) (write-unicode-escape n port))
                 (else (write-char c port)))))
       (string->list text))
      (write-char #\" port)
      (get-output-string port)))
  (define (encode item)
    (cond ((string? item) (string-encode item))
          ((eq? item 'json:null) "null")
          ((eq? item #t) "true")
          ((eq? item #f) "false")
          ((number? item)
           (let ((text (number->string item)))
             (if (json:number-token? text) text
                 (error 'json-encode-error "number is not representable in JSON" item))))
          ((and (pair? item) (eq? (car item) 'json:array))
           (string-append "[" (join "," (map encode (cdr item))) "]"))
          ((and (pair? item) (eq? (car item) 'json:object))
           (string-append "{" (join ","
             (map (lambda (field)
                    (if (or (not (pair? field)) (not (string? (car field))))
                        (error 'json-encode-error "object keys must be strings" field))
                    (string-append (string-encode (car field)) ":" (encode (cdr field))))
                  (cdr item))) "}"))
          (else (error 'json-encode-error "unsupported JSON value" item))))
  (define (join separator strings)
    (if (null? strings) ""
        (let loop ((rest (cdr strings)) (out (car strings)))
          (if (null? rest) out
              (loop (cdr rest) (string-append out separator (car rest)))))))
  (encode value))

(provide 'dat:json)