1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2012 Bert Burgemeister
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 2 of the License, or
7 ;;; (at your option) any later version.
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
14 ;;; You should have received a copy of the GNU General Public License along
15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 (named-readtables:defreadtable json-syntax
22 (:macro-char
#\
[ #'(lambda (stream char
)
23 (declare (ignore char
))
24 (coerce (read-delimited-list #\
] stream
)
26 (:macro-char
#\
{ #'(lambda (stream char
)
27 (declare (ignore char
))
28 (read-delimited-list #\
} stream
)))
29 (:syntax-from nil
#\
) #\
})
30 (:syntax-from nil
#\
) #\
])
31 (:syntax-from nil
#\Space
#\
:)
32 (:syntax-from nil
#\Space
#\
,)
36 (defun pp-json (object &optional stream
)
37 "Write object as indented JSON to stream. Vectors are represented
38 as JSON vectors. Lists, which should have an even number of elements,
39 are represented as JSON objects."
42 (prin1 object stream
))
45 (stream object
:prefix
"{" :suffix
"}")
47 (pprint-exit-if-list-exhausted)
48 (pp-json (pprint-pop) stream
)
50 (pp-json (pprint-pop) stream
)
51 (pprint-exit-if-list-exhausted)
53 (pprint-newline :linear stream
))))
56 (stream (coerce object
'list
) :prefix
"[" :suffix
"]")
58 (pprint-exit-if-list-exhausted)
59 (pp-json (pprint-pop) stream
)
60 (pprint-exit-if-list-exhausted)
62 (pprint-newline :linear stream
))))
64 (princ object stream
))))
66 (defun indent-json (json-text)
69 (let ((*read-default-float-format
* 'long-float
)
70 (*print-right-margin
* 100))
71 (named-readtables:in-readtable json-syntax
)
72 (with-output-to-string (s)
73 (pp-json (read-from-string json-text nil
)
75 (named-readtables:in-readtable
:standard
)))