Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
166 lines (154 sloc) 5.67 KB
; @module Json
; @author Jeff Ober <>, Kanen Flowers <>
; @version 2.1
; @location
; @package
; @description JSON parser and encoder
; <p>Library for parsing JSON data and serializing lisp into JSON.</p>
(context 'Json)
; @syntax (Json:Lisp->Json <expr>)
; @param <expr> expression to be converted to JSON
; <p>Converts expression <expr> to JSON. Association lists and
; contexts are converted into objects. Other lists and arrays are
; converted into JSON arrays.</p>
; @example
; (Json:Lisp->Json '((a 1) (b 2)))
; => "{ 'A': 1, 'b': 2 }"
; (Json:Lisp->Json '(1 2 3 4 5))
; => "[1, 2, 3, 4, 5]"
(define (Lisp->Json lisp)
(case (type-of lisp)
("boolean" (if lisp "true" "false"))
("quote" (Lisp->Json (eval lisp)))
("symbol" (format "'%s'" (name lisp)))
("string" (format "'%s'" (simple-escape lisp)))
("integer" (string lisp))
("float" (string lisp))
("list" (if (assoc? lisp)
(format "{ %s }"
(join (map (fn (pair)
(format "'%s': %s"
(if (symbol? (pair 0))
(name (pair 0))
(string (pair 0)))
(Lisp->Json (pair 1))))
", "))
(string "[" (join (map Lisp->Json lisp) ", ") "]")))
("array" (string "[" (join (map Lisp->Json lisp) ", ") "]"))
("context" (let ((values '()))
(dotree (s lisp)
(push (format "'%s': %s"
(name s)
(Lisp->Json (eval s)))
values -1))
(format "{ %s }" (join values ", "))))
(true (throw-error (format "invalid Lisp->Json type: %s" lisp)))))
(define (simple-escape str)
(replace {[\n\r]+} str {\n} 4)
(replace {'} str {\'} 4)
; @syntax (Json:Json->Lisp <str-json>)
; @param <str-json> a valid JSON string
; <p>Parses a valid JSON string and returns a lisp structure.
; Arrays are converted to lists and objects are converted to
; assocation lists.</p>
; @example
; (Json:Json->Lisp "[1, 2, 3, 4]")
; => (1 2 3 4)
; (Json:Json->Lisp "{ 'x': 3, 'y': 4, 'z': [1, 2, 3] }")
; => (("x" 3) ("y" 4) ("z" (1 2 3)))
(define (Json->Lisp json)
(first (lex (tokenize json))))
(define number-re (regex-comp {^([-+\deE.]+)} 1))
(define identifier-re (regex-comp {([$_a-zA-Z][$_a-zA-Z0-9]*)(.*)} 4))
(define (read-number json-text , matched n)
"Reads in a number in any Javascript-permissible format and attempts to
convert it to a newLISP float. If the number's absolute value is greater
than 1e308 (defined as +/-INF in newLISP), the number is returned as a
(setf json-text (trim json-text))
(when (setf matched (regex number-re json-text 0x10000))
(setf n (pop json-text 0 (matched 5)))
(list (if (> (abs (float n)) 1e308) n (float n)) json-text)))
(define (read-string json-text , quot c escaped split-index str)
(setf quot (pop json-text) str "")
(until (empty? (setf c (pop json-text)))
(if (and (= c quot) (not escaped))
(throw $idx)
(write-buffer str c))
(setf escaped (and (not $it) (= c "\\")))))
(list str json-text))
(define (read-identifier json-text , matched)
(setf json-text (trim json-text))
(setf matched (regex identifier-re json-text 0x10000))
(list (case (nth 3 matched)
("true" true) ("TRUE" true)
("false" nil) ("FALSE" nil)
("null" nil) ("NULL" nil)
(true (nth 3 matched)))
(nth 6 matched)))
(define (tokenize json-text (acc '()) , tok tail n)
(setf json-text (trim json-text))
((empty? json-text) acc)
((regex {^\s+} json-text 4)
(tokenize (replace {^\s+} json-text "" 0) acc))
((regex number-re json-text 0x10000)
(map set '(tok tail) (read-number json-text))
(push tok acc -1)
(tokenize tail acc))
((regex {^['"]} json-text)
(map set '(tok tail) (read-string json-text))
(push tok acc -1)
(tokenize tail acc))
((regex [text]^[{}\[\]:,][/text] json-text)
(setf tok (pop json-text))
(case tok
("{" (push 'OPEN_BRACE acc -1))
("}" (push 'CLOSE_BRACE acc -1))
("[" (push 'OPEN_BRACKET acc -1))
("]" (push 'CLOSE_BRACKET acc -1))
(":" (push 'COLON acc -1))
("," (push 'COMMA acc -1)))
(tokenize json-text acc))
(map set '(tok tail) (read-identifier json-text))
(push tok acc -1)
(tokenize tail acc))))
(define (lex tokens, (tree '()) (loc '(-1)) (depth 0) (mark 0))
; Note: mark is used to match colon-pairings' depth against the current
; depth to prevent commas in a paired value (e.g. foo: [...] or foo: {})
; from popping the stack.
(unless (find (first tokens) '(OPEN_BRACKET OPEN_BRACE))
(throw-error "A JSON object must be an object or array."))
(dolist (tok tokens)
(case tok
(inc depth)
(push (list) tree loc)
(push -1 loc))
(inc depth)
(push (list) tree loc)
(push -1 loc))
(dec depth)
(pop loc))
(dec depth)
(pop loc))
(push (list (pop tree loc)) tree loc)
(push -1 loc)
(setf mark depth))
(when (= mark depth)
(setf mark nil)
(pop loc)))
(push tok tree loc))))
(context MAIN)