Pretty printing json

pretty-print-json.rkt

#lang racket/base
(require json
         data/order)

(define datum< (order-<? datum-order))

(define (pretty-write-json x 
                           #:output-port [o (current-output-port)]
                           #:null [jsnull (json-null)]
                           #:encode [enc 'control]
                           #:indent [indent #f]
                           #:sort-keys? [sort-keys? #f])
  ;; escape: string -> string
  (define (escape m)
    (define ch (string-ref m 0))
    (define r
      (assoc ch '([#\backspace . "\\b"] [#\newline . "\\n"] [#\return . "\\r"]
                                        [#\page . "\\f"] [#\tab . "\\t"]
                                        [#\\ . "\\\\"] [#\" . "\\\""])))
    (define (u-esc n)
      (define str (number->string n 16))
      (define pad (case (string-length str)
                    [(1) "000"] [(2) "00"] [(3) "0"] [else ""]))
      (string-append "\\u" pad str))
    (if r
        (cdr r)
        (let ([n (char->integer ch)])
          (if (n . < . #x10000)
              (u-esc n)
              ;; use the (utf-16 surrogate pair) double \u-encoding
              (let ([n (- n #x10000)])
                (string-append (u-esc (+ #xD800 (arithmetic-shift n -10)))
                               (u-esc (+ #xDC00 (bitwise-and n #x3FF)))))))))
  (define rx-to-encode
    (case enc
      [(control) #rx"[\0-\37\\\"\177]"]
      [(all)     #rx"[\0-\37\\\"\177-\U10FFFF]"]
      [else (raise-type-error 'write-json "encoding symbol" enc)]))
  (define (write-json-string str)
    (write-bytes #"\"" o)
    (write-string (regexp-replace* rx-to-encode str escape) o)
    (write-bytes #"\"" o))
  
  (define space-byte (bytes-ref #" " 0))
  
  (define (write-indent depth)
    (when indent
      (newline o)
      (write-bytes (make-bytes (* depth indent) space-byte) o)))
  (define (write-dedent depth)
    (when indent
      (newline o)
      (write-bytes (make-bytes (* (sub1 depth) indent) space-byte) o)))

  (let loop ([x x]
             [depth 1])
    (cond [(or (exact-integer? x) (inexact-real? x)) (write x o)]
          [(eq? x #f)     (write-bytes #"false" o)]
          [(eq? x #t)     (write-bytes #"true" o)]
          [(eq? x jsnull) (write-bytes #"null" o)]
          [(string? x) (write-json-string x)]
          [(list? x)
           (write-bytes #"[" o)
           (when (pair? x)
             (write-indent depth)
             (loop (car x) (add1 depth))
             (for ([x (in-list (cdr x))]) 
               (write-bytes #"," o)
               (write-indent depth)
               (loop x (add1 depth)))
             (write-dedent depth))
           (write-bytes #"]" o)]
          [(hash? x)
           (write-bytes #"{" o)
           (unless (= (hash-count x) 0)
             (write-indent depth))
           (define first? #t)
           (define key-sequence 
             (if sort-keys?
                 (sort (hash-keys x) datum<)
                 (in-hash-keys x)))
           (for ([k key-sequence])
             (define v (hash-ref x k))
             (unless (symbol? k)
               (raise-type-error 'write-json "legal JSON key value" k))
             (cond
               [first?
                (set! first? #f)]
               [else
                (write-bytes #"," o)
                (write-indent depth)])
             (write (symbol->string k) o) ; no `printf' => proper escapes
             (write-bytes #":" o)
             (loop v (add1 depth)))
           (unless (= (hash-count x) 0)
             (write-dedent depth))
           (write-bytes #"}" o)]
          [else (raise-type-error 'write-json "legal JSON value" x)]))
  (void))


(module+ test
  (require net/url)
  (pretty-write-json (read-json (get-pure-port (string->url "http://www.wescheme.org/loadProject?publicId=5s4dtlNMwe")))
                     #:indent 4
                     #:sort-keys? #t))