json-encode.l #xyzzy

json-encode.l

;;; -*- mode:lisp; package:json -*-

(in-package "json")
(export '(json-encode
	  write-json))

(defun json-encode (obj)
  (with-output-to-string (s)
    (write-json obj s)))

(defun write-json (obj &optional s)
  (cond
   ((consp obj) (write-alist obj s))
   ((stringp obj) (write-js-string obj s))
   ((characterp obj) (write-js-char obj s))
   ((symbolp obj) (write-js-symbol obj s))
   ((or (integerp obj) (single-float-p obj)) (princ obj s))
   ((realp obj)
    (princ (substitute-string (format nil "~F" (* 1d0 obj)) "d" "e") s))
   ((vectorp obj) (write-array obj s))
   (t (type-error obj '(or string char symbol number cons))))
  nil)

(defun write-alist (al s)
  (princ #\{ s)
  (format s "~S:" (string (caar al)))
  (write-json (cdar al) s)
  (loop for (k . v) in (cdr al) do
    (format s ",~S:" (string k))
    (write-json v s))
  (princ #\} s))

(defun write-array (v s)
  (format s "[~{~A~^,~}]" (map 'list #'json-encode v)))

(defun write-js-string (str s)
  (princ #\" s)
  (loop for c across str do (write-js-char c s))
  (princ #\" s))

(defun write-js-char (chr s)
  (case chr
    (#\TAB (format s "\\t"))
    (#\LFD (format s "\\n"))
    (#\RET (format s "\\r"))
    (#\C-h (format s "\\b"))
    (#\C-l (format s "\\f"))
    (#\\ (format s "\\\\"))
    (#\" (format s "\\\""))
    (t (let ((uc (char-unicode chr)))
	 (when uc
	   (if (<= 32 uc 126)
	       (princ chr s)
	     (format s "\\u~4,'0x" uc)))))))

(defun write-js-symbol (sym s)
  (cond ((or (eq sym t) (string= sym "true"))
	 (princ "true" s))
	((or (eq sym nil) (string= sym "null"))
	 (princ "null" s))
	((string= sym "false")
	 (princ "false" sym))
	(t (write-js-string (symbol-name sym) s))))