;;; lib/dat/json.lisp --- JSON format

 ;; JSON parser generator

 ;; There are quite a few json libraries in the CL ecosystem. This

 ;; particular implementation is based on the JSON package here:

 ;; https://github.com/massung/json

 ;; It's object-based (like CL-JSON) instead of using a

 ;; parser-generator.

 ;;; Code:

 (in-package :dat/json)

 (defvar *allow-json-trailing-commas* nil

   "When non-nil, arrange for our json readers to allow trailing

 commas. This binding does not affect writers.

 Trailing commas in json lists and objects is a common source of frustration

 since they're not allowed in the spec. This is easily forgotten when

 generating json from a scripting language without native json support."

   )

 (defun json-trailing-commas-p () *allow-json-trailing-commas*)

 (defsetf json-trailing-commas-p () (val)

   `(setq *allow-json-trailing-commas* ,val))

 (defclass json-object ()

   ((members :initform nil

             :initarg :members

             :accessor json-object-members))

   (:documentation "An associative list of key/value pairs."))

 (defmethod print-object ((obj json-object) stream)

   "Output a JSON object to a stream in readable form."

   (print-unreadable-object (obj stream :type t)

     (let ((*print-level* 1))

       (json-encode obj stream))))

 (defun json-getf (object key &optional value)

   "Find an member's value in a JSON object."

   (let ((place (assoc key (json-object-members object) :test 'string=)))

     (if (null place)

         value

       (values (second place) t))))

 (defun json-setf (object key value)

   "Assign a value to a key in a JSON object."

   (let ((place (assoc key (json-object-members object) :test 'string=)))

     (prog1 value

       (if (null place)

           (let ((k (if (stringp key)

                        key

                      (princ-to-string key))))

             (push (list k value) (json-object-members object)))

         (rplacd place (list value))))))

 (defsetf json-getf json-setf)

 (defun json-decode (string &key (start 0) end)

   "Convert a JSON string into a Lisp object."

   (with-input-from-string (stream string :start start :end end)

     (values (json-read stream)

             (file-position stream))))

 (defmethod deserialize ((obj string) (format (eql :json)) &key (start 0) end)

   (declare (ignore format))

   (json-decode obj :start start :end end))

 (defun json-encode (value &optional stream)

   "Encodes a Lisp value into a stream."

   (json-write value stream))

 (defmethod serialize (obj (format (eql :json)) &key stream)

   (declare (ignore format))

   (if stream

       (json-encode obj stream)

       (with-output-to-string (s)

         (json-encode obj s)

         s)))

 (defun json-enable-reader-macro ()

   "Set the #{ dispatch macro character for reading JSON objects."

   (flet ((json-object-reader (stream char n)

            (declare (ignorable char n))

            (let ((xs (read-delimited-list #\} stream t)))

              (loop

                 for key = (pop xs)

                 for value = (pop xs)

                 ;; stop when nothing is left

                 unless (or xs key value)

                 return (make-instance 'json-object :members pairs)

                 ;; build associative list of key/value pairs

                 collect (list (princ-to-string key) value)

                 into pairs))))

     (set-dispatch-macro-character #\# #\{ #'json-object-reader)

     (set-macro-character #\} (get-macro-character #\) nil))))

 (defun json-read (stream &optional (eof-error-p t) eof-value)

   "Read a JSON object from a stream."

   (let ((c (peek-char t stream eof-error-p :eof)))

     (case c

       (:eof eof-value)

       ;; constants, objects, lists, and strings

       (#\t (json-read-true stream))

       (#\f (json-read-false stream))

       (#\n (json-read-null stream))

       (#\{ (json-read-object stream))

       (#\[ (json-read-list stream))

       (#\" (json-read-string stream))

       ;; must be a number

       (otherwise (json-read-number stream)))))

 (defun json-peek-char (stream expected &key skip-ws)

   "Peek at the next character or token and optionally error if unexpected."

   (declare (optimize (speed 3) (debug 0)))

   (when (equal (peek-char skip-ws stream) expected)

     (read-char stream)))

 (defun json-read-char (stream expected &key skip-ws)

   "Read the next, expected character in the stream."

   (declare (optimize (speed 3) (debug 0)))

   (if (json-peek-char stream expected :skip-ws skip-ws)

       t

     (error "JSON error: unexpected ~s" (read-char stream))))

 (defun json-read-true (stream)

   "Read true from a JSON stream."

   (json-read-char stream #\t :skip-ws t)

   (json-read-char stream #\r)

   (json-read-char stream #\u)

   (json-read-char stream #\e))

 (defun json-read-false (stream)

   "Read false from a JSON stream."

   (prog1 nil

     (json-read-char stream #\f :skip-ws t)

     (json-read-char stream #\a)

     (json-read-char stream #\l)

     (json-read-char stream #\s)

     (json-read-char stream #\e)))

 (defun json-read-null (stream)

   "Read null from a JSON stream."

   (prog1 nil

     (json-read-char stream #\n :skip-ws t)

     (json-read-char stream #\u)

     (json-read-char stream #\l)

     (json-read-char stream #\l)))

 (defun json-read-number (stream)

   "Read a number from a JSON stream."

   (declare (optimize (speed 3) (debug 0)))

   (let ((s (with-output-to-string (s)

              (when (equal (peek-char t stream) #\-)

                (write-char (read-char stream) s))

              ;; read base-10 digits, fraction, and exponent

              (labels ((read-digits ()

                         (let ((c (read-char stream)))

                           (unless (digit-char-p c)

                             (error "JSON error: unexpected ~s" c))

                           ;; write the digits

                           (loop

                              (write-char c s)

                              ;; next digit, test for eof

                              (unless (setf c (read-char stream nil))

                                (return))

                              ;; ensure digit

                              (unless (digit-char-p c)

                                (return (unread-char c stream))))))

                       ;; fractional component

                       (read-fraction ()

                         (when (equal (peek-char nil stream nil) #\.)

                           (write-char (read-char stream) s)

                           (read-digits)))

                       ;; exponent

                       (read-exponent ()

                         (when (equalp (peek-char nil stream nil) #\e)

                           (write-char (read-char stream) s)

                           ;; optional sign

                           (case (peek-char nil stream)

                             (#\- (write-char (read-char stream) s))

                             (#\+ (write-char (read-char stream) s)))

                           ;; exponent

                           (read-digits))))

                ;; read each component; numbers beginning with 0 are a special case

                (if (equalp (peek-char nil stream) #\0)

                    (write-char (read-char stream) s)

                  (read-digits))

                (read-fraction)

                (read-exponent)))))

     (prog1

       (read-from-string s))))

 (defun json-read-string (stream)

   "Read a string from a JSON stream."

   (declare (optimize (speed 3) (debug 0)))

   ;; read the expected quote

   (json-read-char stream #\" :skip-ws t)

   ;; read into an output buffer

   (with-output-to-string (s)

     (loop

        for c = (read-char stream)

        ;; stop at closing quote

        until (char= c #\")

        ;; write character to output

        do (if (char/= c #\\)

               (write-char c s)

             (let ((c (case (read-char stream)

                        (#\n #\newline)

                        (#\t #\tab)

                        (#\f #\formfeed)

                        (#\b #\backspace)

                        (#\r #\return)

                        ;; read unicode character

                        (#\u (let ((x1 (digit-char-p (read-char stream) 16))

                                   (x2 (digit-char-p (read-char stream) 16))

                                   (x3 (digit-char-p (read-char stream) 16))

                                   (x4 (digit-char-p (read-char stream) 16)))

                               (code-char (logior (ash x1 12)

                                                  (ash x2  8)

                                                  (ash x3  4)

                                                  (ash x4  0)))))

                        ;; verbatim character

                        (otherwise c))))

               (write-char c s))))))

 (defun json-read-list (stream)

   "Read a list of JSON values."

   (declare (optimize (speed 3) (debug 0)))

   ;; read the expected open bracket

   (json-read-char stream #\[ :skip-ws t)

   ;; check for an empty list

   (if (json-peek-char stream #\] :skip-ws t)

       nil

     (loop

       for x = (json-read stream)

       collect x

       into xs

       ;; check for another element

       while (and (json-peek-char stream #\, :skip-ws t)

                   (unless (and (json-trailing-commas-p) (equal #\] (peek-char t stream)))

                    t))

        ;; return the final list

        finally (return (prog1 xs

                          (json-read-char stream #\] :skip-ws t))))))

 (defun json-read-object (stream)

   "Read an associative list of key/value pairs into a JSON object."

   (declare (optimize (speed 3) (debug 0)))

   ;; read the expected open brace

   (json-read-char stream #\{ :skip-ws t)

   ;; check for an empty object

   (if (json-peek-char stream #\} :skip-ws t)

       (make-instance 'json-object)

     (loop

        for key = (json-read-string stream)

        for value = (progn

                      (json-read-char stream #\: :skip-ws t)

                      (json-read stream))

        ;; build the associative list of members

        collect (list key value)

        into xs

        ;; check for another element

        while (and (json-peek-char stream #\, :skip-ws t)

                   (unless (and (json-trailing-commas-p) (equal #\} (peek-char t stream)))

                     t))

       ;; return the final list

       finally (return (prog1 (make-instance 'json-object :members xs)

                         (json-read-char stream #\} :skip-ws t))))))

 (defmethod json-write ((value (eql t)) &optional stream)

   "Encode the true value."

   (declare (ignore value))

   (format stream "~<true~>"))

 (defmethod json-write ((value (eql nil)) &optional stream)

   "Encode the null constant."

   (declare (ignore value))

   (format stream "~<null~>"))

 (defmethod json-write ((value symbol) &optional stream)

   "Encode a symbol to a stream."

   (json-write (symbol-name value) stream))

 (defmethod json-write ((value number) &optional stream)

   "Encode a number to a stream."

   (format stream "~<~a~>" value))

 (defmethod json-write ((value ratio) &optional stream)

   "Encode a ratio to a stream."

   (format stream "~<~a~>" (float value)))

 (defmethod json-write ((value string) &optional stream)

   "Encode a string as a stream."

   (flet ((encode-char (c)

            (cond

             ((char= c #\\) "\\\\")

             ((char= c #\") "\\\"")

             ((char= c #\newline) "\\n")

             ((char= c #\tab) "\\t")

             ((char= c #\formfeed) "\\f")

             ((char= c #\backspace) "\\b")

             ((char= c #\return) "\\r")

             ((char> c #\~)

              (format nil "\\u~16,4,'0r" (char-code c)))

             (t

              (string c)))))

     (format stream "~<\"~{~a~}\"~>" (map 'list #'encode-char value))))

 (defmethod json-write ((value pathname) &optional stream)

   "Encode a pathname as a stream."

   (json-write (namestring value) stream))

 (defmethod json-write ((value vector) &optional stream)

   "Encode an array to a stream."

   (let ((*print-pretty* t)

         (*print-length* nil)

         (*print-lines* nil)

         (*print-right-margin* 72))

     (pprint-logical-block (stream nil :prefix "[" :suffix "]")

       (when (plusp (length value))

         (json-write (aref value 0)))

       (loop

          for i from 1 below (length value)

          do (progn

               (write-char #\, stream)

               (pprint-newline :fill)

               (pprint-indent :block 0)

               (json-write (aref value i) stream))))))

 (defmethod json-write ((value list) &optional stream)

   "Encode a list to a stream."

   (let ((*print-pretty* t)

         (*print-length* nil)

         (*print-lines* nil)

         (*print-right-margin* 72))

     (pprint-logical-block (stream value :prefix "[" :suffix "]")

       (pprint-exit-if-list-exhausted)

       (loop

          (json-write (pprint-pop) stream)

          (pprint-exit-if-list-exhausted)

          (write-char #\, stream)

          (pprint-newline :fill)

          (pprint-indent :block 0)))))

 (defmethod json-write ((value hash-table) &optional stream)

   "Encode a hash-table to a stream."

   (let ((*print-pretty* t)

         (*print-length* nil)

         (*print-lines* nil)

         (*print-right-margin* 72))

     (let ((keys (loop for key being each hash-keys in value collect key)))