Json is widely used and could not find a decent json parse for xyzzy.
So I decided to create on by myself.
Here is the source code though not very detailed version, I used for my everyday work and happy with it.
Created almost one year ago, almost forgot the details...
(provide "formatter")
(in-package "editor")
(export 'fmtjson)
(defvar **lv** 0)
(defmacro setlvl (bdy)
`(progn
(setq **lv** (1+ **lv**))
,bdy
(setq **lv** (1- **lv**))))
;;(defmacro fnlvl (fn param bdy)
;; `(defun fn (param)
;; ))
(defmacro spc(n)
`(let ((str ""))
(dotimes (ct (* ,n 2) str)
(setq str (format nil "~A " str)))))
(defmacro fmtspc (iot fmt parm)
`(format ,iot (concatenate 'string "~A" ,fmt) (spc **lv**) ,@parm))
(defun getobj (strm)
(let ((x nil)
(y nil))
(let ((ret
(if (eq (read-char strm nil) #\{)
(progn
(setq **lv** (1+ **lv**))
;;(while (eq (setq x (read-char strm nil)) #\Space))
(setq x (read-char strm nil))
(if (eq x #\})
(format nil "{~%~A}~%~A" (spc (1- **lv**)) (spc **lv**))
(progn
(unread-char x strm)
(setq y (getmembr strm))
;(while (eq (setq x (read-char strm nil)) #\Space))
;; have to make sure inner getmembr does not consume the #\}.
;;(if (eq x nil)
;; (progn
;; (setq y (substring y 0 4))
;; (setq x #\})))
;;(unread-char x strm)
(if (eq (read-char strm nil) #\})
(format nil "{~%~A~A~A}" (spc **lv**) y (spc (1- **lv**)) ))))))))
(setq **lv** (1- **lv**))
ret)))
(defun getmembr (strm)
(let ((x (getpair strm))
(y nil))
(if (eq (setq y (read-char strm nil)) #\,)
(format nil "~A,~%~A~A" x (spc **lv**) (getmembr strm))
(progn
(unread-char y strm)
(format nil "~A~%" x (spc **lv**))))))
(defun getpair (strm)
(let ((x (getstr strm)))
(read-char strm nil)
(format nil "~A : ~A" x (getval strm))))
(defun getstr (strm)
(read-char strm nil)
(let ((str "")
(x nil))
;(x (read-char strm nil)))
(while (not (eq (setq x (read-char strm nil)) #\"))
;(if (eq x #\\)
; (progn
; (setq str (format "~A~C" str x))
; (format "~A~C" str (read-char strm nil)))
(setq str (format nil "~A~C" str x)))
; (progn
; (unread-char x strm)
(format nil "\"~A\"" str)))
(defun getval(strm)
;;;(getstr strm))
(let ((x (read-char strm nil)))
(cond ((eq x #\")
(unread-char x strm)
(getstr strm))
((eq x #\{)
(unread-char x strm)
(getobj strm))
((eq x #\[)
(unread-char x strm)
(getarr strm))
((or (eq x #\-)
(and (char>= x #\0)
(char<= x #\9)))
(unread-char x strm)
(getnum strm))
((eq x #\t)
(unread-char x strm)
(getT strm))
((eq x #\f)
(unread-char x strm)
(getF strm))
((eq x #\n)
(unread-char x strm)
(getN strm))
(t (unread-char x strm)))))
(defun getarr (strm)
(setq **lv** (1+ **lv**))
(read-char strm nil)
(let ((x (read-char strm nil)))
(let ((ret
(if (eq x #\])
(format nil "[~%~A]~%~A" (spc (1- **lv**)) (spc **lv**))
(progn
(unread-char x strm)
(let ((y (getelm strm)))
(if (eq (read-char strm nil) #\])
(format nil "[~%~A~A~A]" (spc **lv**) y (spc (1- **lv**)))
y))))))
(setq **lv** (1- **lv**))
ret)))
(defun getelm (strm)
(let ((x (getval strm))
(y (read-char strm nil)))
(if (eq y #\,)
(format nil "~A ,~%~A~A" x (spc **lv**) (getelm strm))
(progn
(unread-char y strm)
(format nil "~A~%" x (spc **lv**))))))
(defun getnum (strm)
(let ((x (getint strm))
(y (read-char strm nil)))
(cond ((eq y #\.)
(unread-char y strm)
(let ((z (getfrac strm))
(i (read-char strm nil)))
(if (or (eq i #\e)
(eq i #\E))
(progn
(unread-char i strm)
(format nil "~A~A~A" x z (getexp strm)))
(progn
(unread-char i strm)
(format nil "~A~A" x z)))))
((or (eq y #\e)
(eq y #\E))
(unread-char y strm)
(format nil "~A~A" x (getexp strm)))
(t (unread-char y strm)
(format nil "~A" x)))))
(defun getfrac (strm)
(let ((x (read-char strm nil)))
(format nil "~C~A" x (getdigt strm))))
(defun getexp (strm)
(let ((e (read-char strm nil))
(s (read-char strm nil)))
(if (or (eq s #\+)
(eq s #\-))
(format nil "~C~C~A" e s (getdigt strm))
(progn
(unread-char s strm)
(format nil "~C~A" e (getdigt strm))))))
(defun getint (strm)
(let ((dig (read-char strm nil)))
(cond ((eq dig #\0)
(format nil "~C" dig))
((eq dig #\-)
(let ((x (read-char strm nil)))
(if (eq x #\0)
(format nil "~C~C" dig x)
(format nil "~C~C~A" dig x (getdigt strm)))))
((and (char>= dig #\1)
(char<= dig #\9))
;(unread-char dig strm)
(format nil "~C~A" dig (getdigt strm)))
(t (unread-char dig strm)))))
(defun getdigt (strm)
(let ((dgt (read-char strm nil)))
(if (not (and (char>= dgt #\0)
(char<= dgt #\9)))
(progn
(unread-char dgt strm)
"")
(format nil "~A~A" (string dgt) (getdigt strm)))))
(defun getT (strm)
(let ((str ""))
(while (alpha-char-p (setq x (read-char strm nil)))
(setq str (format nil "~A~C" str x)))
(unread-char x strm)
str))
(defun getF (strm)
(let ((str ""))
(while (alpha-char-p (setq x (read-char strm nil)))
(setq str (format nil "~A~C" str x)))
(unread-char x strm)
str))
(defun getN (strm)
(let ((str ""))
(while (alpha-char-p (setq x (read-char strm nil)))
(setq str (format nil "~A~C" str x)))
(unread-char x strm)
str))
(defun fmtjson ()
(interactive)
(setq **lv** 0)
(case (get-selection-type)
((1 2 3)
(kill-selection)
;(let ((str (remove #\RET (remove #\TAB (remove #\LFD (cdr (car *selection-ring*)))))))
(let ((flg 0) (str ""))
(map nil
#'(lambda (c)
(case c
(#\"
(if (eq flg 1)
(setq flg 0)
(setq flg 1))
(setq str (format nil "~A~C" str c)))
((#\SPC #\RET #\LFD #\TAB)
(if (eq flg 1)
(setq str (format nil "~A~C" str c))))
(t (setq str (format nil "~A~C" str c)))))
(cdr (car *selection-ring*)))
(case (char str 0)
(#\{
(insert (format nil "~A" (with-input-from-string (strm str) (getobj strm)))))
(#\[
(insert (format nil "~A" (with-input-from-string (strm str) (getarr strm))))))))))
