--- a/.TODO.done Mon Aug 31 22:18:48 2020 -0400
+++ b/.TODO.done Mon Aug 31 23:11:35 2020 -0400
@@ -1,3 +1,4 @@
+Indentation. | id:0184922ad2c249da5361f439f6449fadcb27d43c
Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04
Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58
--- a/TODO Mon Aug 31 22:18:48 2020 -0400
+++ b/TODO Mon Aug 31 23:11:35 2020 -0400
@@ -1,4 +1,3 @@
-Indentation. | id:0184922ad2c249da5361f439f6449fadcb27d43c
Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
--- a/src/basic.lisp Mon Aug 31 22:18:48 2020 -0400
+++ b/src/basic.lisp Mon Aug 31 23:11:35 2020 -0400
@@ -20,6 +20,8 @@
If both the size and depth limits are exceeded by exactly the same character,
it is unspecified which of the two errors will be signaled.")
+(defparameter *indent* nil)
+
(defstruct (input (:constructor make-input%))
(stream nil :type stream)
@@ -366,12 +368,20 @@
(t (format stream "\\u~4,'0X" (char-code char)))))
-(defgeneric print% (thing stream))
+(declaim (inline indent))
-(defmethod print% ((thing null) stream)
+(defun indent (i stream)
+ (when i
+ (format stream "~%~v@T" i)))
+
+(defgeneric print% (thing stream indent))
+
+(defmethod print% ((thing null) stream indent)
+ (declare (ignore indent))
(write-string "null" stream))
-(defmethod print% ((thing string) stream)
+(defmethod print% ((thing string) stream indent)
+ (declare (ignore indent))
(write-char #\" stream)
(loop :for char :across thing
:do (if (requires-escape-p char)
@@ -379,44 +389,57 @@
(write-char char stream)))
(write-char #\" stream))
-(defmethod print% ((thing vector) stream)
+(defmethod print% ((thing vector) stream indent &aux (first t))
(write-char #\[ stream)
- (loop :with first = t
- :for object :across thing
- :do (progn (if first
- (setf first nil)
- (write-char #\, stream))
- (print% object stream)))
- (write-char #\] stream))
-
-(defmethod print% ((thing hash-table) stream)
- (write-char #\{ stream)
- (loop :with first = t
- :for name :being :the hash-keys :in thing :using (hash-value value)
+ (when indent (incf indent 2))
+ (loop :for object :across thing
:do (progn (if first
(setf first nil)
(write-char #\, stream))
- (assert (stringp name))
- (print% name stream)
- (write-char #\: stream)
- (print% value stream)))
+ (indent indent stream)
+ (print% object stream indent)))
+ (when (and indent (not first))
+ (indent (- indent 2) stream))
+ (write-char #\] stream))
+
+(defmethod print% ((thing hash-table) stream indent &aux (first t))
+ (write-char #\{ stream)
+ (when indent (incf indent 2))
+ (maphash (lambda (name value)
+ (if first
+ (setf first nil)
+ (write-char #\, stream))
+ (indent indent stream)
+ (assert (stringp name))
+ (print% name stream indent)
+ (write-char #\: stream)
+ (when indent (write-char #\space stream))
+ (print% value stream indent))
+ thing)
+ (when (and indent (not first))
+ (indent (- indent 2) stream))
(write-char #\} stream))
-(defmethod print% ((thing single-float) stream)
+(defmethod print% ((thing single-float) stream indent)
+ (declare (ignore indent))
(let ((*read-default-float-format* 'single-float))
(princ thing stream)))
-(defmethod print% ((thing double-float) stream)
+(defmethod print% ((thing double-float) stream indent)
+ (declare (ignore indent))
(let ((*read-default-float-format* 'double-float))
(princ thing stream)))
-(defmethod print% ((thing integer) stream)
+(defmethod print% ((thing integer) stream indent)
+ (declare (ignore indent))
(format stream "~D" thing))
-(defmethod print% ((thing (eql :false)) stream)
+(defmethod print% ((thing (eql :false)) stream indent)
+ (declare (ignore indent))
(write-string "false" stream))
-(defmethod print% ((thing (eql :true)) stream)
+(defmethod print% ((thing (eql :true)) stream indent)
+ (declare (ignore indent))
(write-string "true" stream))
@@ -456,9 +479,10 @@
(defun print (object &optional (stream *standard-output*))
(let ((*read-default-float-format* 'double-float)
- (*print-base* 10))
+ (*print-base* 10)
+ (indent (if *indent* 0 nil)))
(etypecase stream
- (stream (print% object stream) (values))
- ((eql t) (print% object *standard-output*) (values))
- (null (with-output-to-string (s) (print% object s))))))
+ (stream (print% object stream indent) (values))
+ ((eql t) (print% object *standard-output* indent) (values))
+ (null (with-output-to-string (s) (print% object s indent))))))
--- a/src/mop.lisp Mon Aug 31 22:18:48 2020 -0400
+++ b/src/mop.lisp Mon Aug 31 23:11:35 2020 -0400
@@ -240,15 +240,18 @@
;;;; Printing -----------------------------------------------------------------
-(defun print-json-class (class thing stream &aux (first t))
+(defun print-json-class (class thing stream indent &aux (first t))
(write-char #\{ stream)
+ (when indent (incf indent 2))
(flet ((print-pair (k v)
(if first
(setf first nil)
(write-char #\, stream))
- (print% k stream)
+ (indent indent stream)
+ (print% k stream indent)
(write-char #\: stream)
- (print% v stream)))
+ (when indent (write-char #\space stream))
+ (print% v stream indent)))
(loop :for (slot name before-print) :in (slot-alist class)
:when (slot-boundp thing slot)
:do (let ((value (slot-value thing slot)))
@@ -257,10 +260,12 @@
value)))
:finally (when (slot-boundp thing 'preserved)
(maphash #'print-pair (slot-value thing 'preserved)))))
+ (when (and indent (not first))
+ (terpri stream))
(write-char #\} stream))
-(defmethod print% ((thing json-object) stream)
+(defmethod print% ((thing json-object) stream indent)
(let ((class (class-of thing)))
(if (allow-print class)
- (print-json-class class thing stream)
+ (print-json-class class thing stream indent)
(error "Class ~S does not allow printing." class))))
--- a/src/wrappers.lisp Mon Aug 31 22:18:48 2020 -0400
+++ b/src/wrappers.lisp Mon Aug 31 23:11:35 2020 -0400
@@ -43,14 +43,14 @@
(funcall (wrapper-read wrapper)
(read% (wrapper-c wrapper) (wrapper-cc wrapper) input)))
-(defun print-with-wrapper (wrapper thing stream)
- (print% (funcall (wrapper-print wrapper) thing) stream))
+(defun print-with-wrapper (wrapper thing stream indent)
+ (print% (funcall (wrapper-print wrapper) thing) stream indent))
-(defmethod print% (thing stream)
+(defmethod print% (thing stream indent)
(let* ((class (class-of thing))
(wrapper (find-wrapper (class-name class))))
(if wrapper
- (print-with-wrapper wrapper thing stream)
+ (print-with-wrapper wrapper thing stream indent)
(error "Don't know how to print object ~S of class ~S as JSON, ~
because it's not a JSON class and doesn't have any wrapper(s)."
thing class))))
--- a/test/tests.lisp Mon Aug 31 22:18:48 2020 -0400
+++ b/test/tests.lisp Mon Aug 31 23:11:35 2020 -0400
@@ -76,7 +76,9 @@
(jarl:read class-designator (jarl:print object nil)))
(defun check-roundtrips (object)
- (is (same object (roundtrip-object t object))))
+ (is (same object (roundtrip-object t object)))
+ (let ((jarl::*indent* t))
+ (is (same object (roundtrip-object t object)))))
(defun check-errors (line col string)
(dolist (class '(t nil)) ; todo check discarding errors too
@@ -468,6 +470,11 @@
:id nil
:foos (v (foo :i 10) (foo :n nil :v (v)))))
+(define-test class-indent
+ (let ((jarl::*indent* t))
+ (is (string= (format nil "{~% \"v\": [~% 1,~% 2,~% 3~% ]~%}")
+ (jarl:print (make-instance 'foo :v #(1 2 3)) nil)))))
+
;;;; Wrappers -----------------------------------------------------------------
(defclass w ()