indent-json.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2012 Bert Burgemeister
   3 ;;;
   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.
   8 ;;;
   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.
  13 ;;;
  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.
  17
  18 (in-package :phoros)
  19
  20 (named-readtables:defreadtable json-syntax
  21   (:merge :standard)
  22   (:macro-char #\[ #'(lambda (stream char)
  23                        (declare (ignore char))
  24                        (coerce (read-delimited-list #\] stream)
  25                                'vector)))
  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 #\,)
  33   (:case :preserve))
  34
  35
  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."
  40   (cond
  41     ((stringp object)
  42      (prin1 object stream))
  43     ((consp object)
  44      (pprint-logical-block
  45          (stream object :prefix "{" :suffix "}")
  46        (loop
  47           (pprint-exit-if-list-exhausted)
  48           (pp-json (pprint-pop) stream)
  49           (princ ":" stream)
  50           (pp-json (pprint-pop) stream)
  51           (pprint-exit-if-list-exhausted)
  52           (princ "," stream)
  53           (pprint-newline :linear stream))))
  54     ((vectorp object)
  55      (pprint-logical-block
  56          (stream (coerce object 'list) :prefix "[" :suffix "]")
  57        (loop
  58           (pprint-exit-if-list-exhausted)
  59           (pp-json (pprint-pop) stream)
  60           (pprint-exit-if-list-exhausted)
  61           (princ "," stream)
  62           (pprint-newline :linear stream))))
  63     (t
  64      (princ object stream))))
  65
  66 (defun indent-json (json-text)
  67   "Indent json-text."
  68   (unwind-protect
  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)
  74                       s)))
  75     (named-readtables:in-readtable :standard)))