#lang scheme
(require "simple-json.ss")
(require "prettify.ss")
(require "../prelude.ss")

(provide render-jvalue)

(define (render-jvalue jval)
  (define (field k v)
    (<> (<> (doc-string k) (text ": "))
        (render-jvalue v)))
  (cond [(jbool? jval)   (text (if (get-bool jval)
                                   "true"
                                   "false"))]
        [(jnull? jval)   (text "null")]
        [(jnumber? jval) (double (get-double jval))]
        [(jstring? jval) (doc-string (get-string jval))]
        [(jarray? jval)  (series #\[ #\] render-jvalue (get-array jval))]
        [(jobject? jval) (series #\{ #\} field         (get-object jval))]))

(define (doc-string s) (enclose #\" #\" (hcat (map one-char (string->list s)))))
(define (enclose left right x) (<> (char left) (<> x (char right))))

(define (one-char c)
  (define (must-escape? c)
      (or (char<? c #\space)
          (char=? c #\u7F)
          (char>? c #\uFF)))
  
  (let ([escape (assv c simple-escapes)])
    (cond [escape (text (cdr escape))]
          [(must-escape? c) (hex-escape c)]
          [else (char c)])))


(define simple-escapes 
  '((#\backspace . "\\b")
    (#\newline   . "\\n")
    (#\page      . "\\f")
    (#\return    . "\\r")
    (#\tab       . "\\t")
    (#\\         . "\\\\")
    (#\"         . "\\\"")
    (#\/         . "\\/")))

(define (hex-escape c)
    (text (if (char>? c #\uffff)  
              (astral (char->integer c))
              (format "~c" c))))

(define (astral d) 
  (let ([a (bitwise-and (arithmetic-shift d -10) 1023)]
        [b (bitwise-and d 1023)])
    (<> (format "~c" (integer->char (+ a 55296)))
        (format "~c" (integer->char (+ a 56320))))))

(define (series open close item ds)
  (enclose open 
           close
           (fsep (punctuate (char #\,) (map item ds)))))