# HG changeset patch # User Steve Losh # Date 1598929895 14400 # Node ID f91e6bc7fd5687d6818fc8bb313c5abb695c4066 # Parent f0020e905c947210a94d308e2200d430b4e43732 Add indentation Not sure if I'm going to keep this or not. We'll see... diff -r f0020e905c94 -r f91e6bc7fd56 .TODO.done --- 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 diff -r f0020e905c94 -r f91e6bc7fd56 TODO --- 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 diff -r f0020e905c94 -r f91e6bc7fd56 src/basic.lisp --- 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)))))) diff -r f0020e905c94 -r f91e6bc7fd56 src/mop.lisp --- 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)))) diff -r f0020e905c94 -r f91e6bc7fd56 src/wrappers.lisp --- 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)))) diff -r f0020e905c94 -r f91e6bc7fd56 test/tests.lisp --- 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 ()