medea / medea.scm

(module medea


(import chicken scheme)
(use srfi-14 srfi-69 lazy-seq
     (except comparse)
     (only srfi-1 cons* find remove)
     (only data-structures compose constantly identity alist-ref conc string-translate*)
     (only srfi-13 string-pad)
     (only ports with-output-to-port with-output-to-string))

(define (vector-for-each proc vec)
  (let ((len (vector-length vec)))
    (do ((i 0 (fx+ i 1)))
        ((fx>= i len))
      (proc (vector-ref vec i)))))

(define json-parsers
  (make-parameter `((string . ,identity)
                    (number . ,string->number)
                    (member . ,(lambda (name value)
                                 (cons (string->symbol name) value)))
                    (object . ,identity)
                    (array  . ,list->vector))))

(define (parser-ref name)
  (alist-ref name (json-parsers)))

(define (handle-number x)
  (result ((parser-ref 'number) x)))

(define (handle-array args)
  (result ((parser-ref 'array) args)))

(define (handle-member name value)
  (result ((parser-ref 'member ) name value)))

(define (handle-object args)
  (result ((parser-ref 'object) args)))

(define (handle-string string)
  (result ((parser-ref 'string) string)))

(define (handle-unicode u)
  (result (##sys#char->utf8-string (integer->char (string->number u 16)))))

(define (handle-escape e)
   (case e
     ((#\\) #\\)
     ((#\/) #\/)
     ((#\") #\")
     ((#\b) #\backspace)
     ((#\f) #\page)
     ((#\n) #\newline)
     ((#\r) #\return)
     ((#\t) #\tab))))

(define handle-true (constantly (result #t)))
(define handle-false (constantly (result #f)))
(define handle-null (constantly (result 'null)))

(define json-escape-chars

(define json-escapes
  (map (lambda (e c)
         (cons (string e) (string #\\ c)))
       (string->list "\"\\\b\f\n\r\t")
       (string->list json-escape-chars)))

(define char-set:json-escape
  (string->char-set json-escape-chars))

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

(define consume-trailing-whitespace?
  (make-parameter #f))

(define document
  (include "grammar.scm"))

(define (read-json #!optional (input (current-input-port))
                   #!key (memoize? #t) (consume-trailing-whitespace #t))
  (parameterize ((consume-trailing-whitespace? consume-trailing-whitespace))
    (parse document
           (cond ((input-port? input)
                  (input-port->lazy-seq input read-char))
                 ((string? input)
                  (string->list input))
                 (else input))
           memoize: memoize?)))

(define (unparse-string s)
  (display #\")
  (display (string-translate* s json-escapes))
  (display #\"))

(define (for-each/delimiter proc list delimiter)
  (let ((size (if (vector? list)
                  (vector-length list)
                  (length list)))
        (count 0))
    ((if (vector? list) vector-for-each for-each)
     (lambda (d #!optional (ad d))
       (proc ad)
       (set! count (add1 count))
       (unless (= count size)
         (display #\,)))

(define json-unparsers
   (list (cons list?
               (lambda (object)
                 (display #\{)
                  (lambda (member)
                    (unparse-string (symbol->string (car member)))
                    (display #\:)
                    (write-json (cdr member)))
                 (display #\})))

         (cons vector?
               (lambda (array)
                 (display #\[)
                 (for-each/delimiter write-json array #\,)
                 (display #\])))

         (cons string? unparse-string)
         (cons number? write)
         (cons (cut eq? <> #t) (lambda (o) (display "true")))
         (cons (cut eq? <> #f) (lambda (o) (display "false")))
         (cons (cut eq? <> 'null) (lambda (o) (display "null")))
         (cons (constantly #t)
               (lambda datum
                 (error 'write-json "don't know how to write datum as JSON" datum))))))

(define (write-json object #!optional (port (current-output-port)))
  (with-output-to-port port
    (lambda ()
      ((cdr (find (lambda (unparser)
                    ((car unparser) object))

(define (json->string object)
  (with-output-to-string (lambda () (write-json object))))

Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.