--- a/.TODO.done Mon Dec 07 23:17:47 2020 -0500
+++ b/.TODO.done Tue Dec 15 00:03:48 2020 -0500
@@ -11,6 +11,7 @@
Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
+Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd
Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
Remove wrappers for now. | id:fb86c2b6a6322ef04df60f74e3b3fefffc1c2d96
--- a/TODO Mon Dec 07 23:17:47 2020 -0500
+++ b/TODO Tue Dec 15 00:03:48 2020 -0500
@@ -1,4 +1,3 @@
Write documentation. | id:8612eacd92edd0b4b196feb5d084d58e86cedeeb
Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
-Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/src/mop.lisp Mon Dec 07 23:17:47 2020 -0500
+++ b/src/mop.lisp Tue Dec 15 00:03:48 2020 -0500
@@ -21,6 +21,9 @@
(allow-print :accessor allow-print :initarg :allow-print :initform t)
(allow-read :accessor allow-read :initarg :allow-read :initform t)))
+(defun json-class-p (object)
+ (typep object 'json-class))
+
(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
t)
@@ -38,6 +41,19 @@
(before-print :initarg :json/before-print :accessor before-print :initform nil)
(after-read :initarg :json/after-read :accessor after-read :initform nil)))
+(defun json-direct-slot-p (slot)
+ (typep slot 'json-direct-slot-definition))
+
+(defun json-effective-slot-p (slot)
+ (typep slot 'json-effective-slot-definition))
+
+(defun json-direct-slots (direct-slots)
+ (remove-if-not #'json-direct-slot-p direct-slots))
+
+(defun json-effective-slots (effective-slots)
+ (remove-if-not #'json-effective-slot-p effective-slots))
+
+
(defmethod make-instance ((class (eql (find-class 'json-effective-slot-definition)))
&rest args
&key initargs name &allow-other-keys)
@@ -54,11 +70,16 @@
args)))
+(defun plist-keys (plist)
+ (loop :for (k) :on plist :by #'cddr :collect k))
+
(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
- (if (getf initargs :json)
+ (if (intersection (plist-keys initargs)
+ '(:json :json/name :json/before-print :json/after-read))
(find-class 'json-direct-slot-definition)
(call-next-method)))
+
(defvar *effective-slot-definition-class* nil)
(defmethod c2mop:effective-slot-definition-class ((class json-class) &rest initargs)
@@ -69,35 +90,34 @@
;; know which class to use here.
(or *effective-slot-definition-class* (call-next-method)))
+
+(defmacro found-or (form default)
+ (let ((result (gensym "RESULT"))
+ (found (gensym "FOUND")))
+ `(multiple-value-bind (,result ,found) ,form
+ (if ,found ,result ,default))))
+
+(defun coalesce-most-specific-value (dslots slot-name)
+ (dolist (dslot dslots (values nil nil))
+ (when (slot-boundp dslot slot-name)
+ (return (values (slot-value dslot slot-name) t)))))
+
(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
- (if (not (some (lambda (dslot)
- (typep dslot 'json-direct-slot-definition))
- direct-slots))
+ (if (not (some #'json-direct-slot-p direct-slots))
(call-next-method)
(let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
(eslot (call-next-method))
- (dslot (first direct-slots)))
- ;; todo be smarter about coalescing this stuff
- (setf (json-name eslot) (if (slot-boundp dslot 'json-name)
- (json-name dslot)
- (funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
- (json-class eslot) (if (slot-boundp dslot 'json-class)
- (canonicalize-class-designator (json-class dslot))
- '(t))
+ (dslots (remove-if-not #'json-direct-slot-p direct-slots)))
+ (setf (json-name eslot) (found-or (coalesce-most-specific-value dslots 'json-name)
+ (funcall (slot-name-to-json-name class) name))
+ (json-class eslot) (canonicalize-class-designator
+ (found-or (coalesce-most-specific-value dslots 'json-class) t))
(json-initarg eslot) (first (c2mop:slot-definition-initargs eslot))
- (after-read eslot) (if (slot-boundp dslot 'after-read)
- (after-read dslot)
- nil)
- (before-print eslot) (if (slot-boundp dslot 'before-print)
- (before-print dslot)
- nil))
+ (after-read eslot) (coalesce-most-specific-value dslots 'after-read)
+ (before-print eslot) (coalesce-most-specific-value dslots 'before-print))
eslot)))
-(defun json-slots (effective-slots)
- (remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
- effective-slots))
-
(defun make-slot-map (effective-slots)
"Return a slot map for the JSON slots in `effective-slots`, used when reading.
@@ -105,7 +125,7 @@
after-read)}`.
"
- (let* ((slots (json-slots effective-slots))
+ (let* ((slots (json-effective-slots effective-slots))
(result (make-hash-table :test #'equal :size (length slots))))
(dolist (slot slots)
(destructuring-bind (c &optional cc) (json-class slot)
@@ -123,7 +143,7 @@
(cons (c2mop:slot-definition-name slot)
(list (json-name slot)
(before-print slot))))
- (json-slots effective-slots)))
+ (json-effective-slots effective-slots)))
(defmethod c2mop:compute-slots :around ((class json-class))
@@ -133,20 +153,47 @@
effective-slots))
+(defun json-superclasses (class)
+ (remove-if-not #'json-class-p (c2mop:class-direct-superclasses class)))
+
(defmethod shared-initialize :around
((class json-class) slot-names
&rest initargs
&key slot-name-to-json-name unknown-slots allow-print allow-read
&allow-other-keys)
- (flet ((arg (initarg args)
- (when args ; todo assert length = 1
- (list initarg (first args)))))
- (apply #'call-next-method class slot-names
- (append (arg :slot-name-to-json-name slot-name-to-json-name)
- (arg :unknown-slots unknown-slots)
- (arg :allow-read (or allow-read '(t)))
- (arg :allow-print (or allow-print '(t)))
- initargs))))
+ ;; This is tricky. We need to handle a couple of cases:
+ ;;
+ ;; * Defining a class for the first time.
+ ;; * Redefining a class, possibly *removing* some of the initargs.
+ ;;
+ ;; And we need to handle inheritance properly. Our strategy:
+ ;;
+ ;; * If this defclass has an explicit value for this initarg, always use it.
+ ;; * Otherwise, if this class inherits from a json-class, use its value for
+ ;; the initarg.
+ ;; * TODO: if it inherits from multiple json-classes, pick the first I guess?
+ ;; Or does that not make sense for e.g allow-read and allow-print?.
+ ;; * Otherwise, use the appropriate default.
+ (let ((superclasses (json-superclasses class)))
+ (flet ((arg (slot-name args default)
+ (case (length args)
+ ;; If the user specified a value, use it .
+ (1 (first args))
+ (0 (if superclasses
+ ;; Otherwise, if we have a JSON superclass, inherit.
+ (slot-value (first superclasses) slot-name)
+ ;; Otherwise, use the default.
+ default))
+ (t (error "json-class option ~S must have one argument, but got ~D: ~S."
+ (intern (symbol-name slot-name) :keyword)
+ (length args)
+ args)))))
+ (apply #'call-next-method class slot-names
+ :slot-name-to-json-name (arg 'slot-name-to-json-name slot-name-to-json-name #'lisp-case-to-snake-case)
+ :unknown-slots (arg 'unknown-slots unknown-slots :discard)
+ :allow-read (arg 'allow-read allow-read t)
+ :allow-print (arg 'allow-print allow-print t)
+ initargs))))
(defun patch-direct-superclasses (direct-superclasses)
@@ -184,7 +231,6 @@
;;;; Read ---------------------------------------------------------------------
-
(defun parse-json-class (class-name class input)
(unless (allow-read class)
(error "Class ~S does not allow reading." class))
--- a/test/tests.lisp Mon Dec 07 23:17:47 2020 -0500
+++ b/test/tests.lisp Tue Dec 15 00:03:48 2020 -0500
@@ -49,13 +49,16 @@
(defun slot= (a b slot)
- (if (not (slot-boundp a slot))
- (not (slot-boundp b slot))
- (same (slot-value a slot)
- (slot-value b slot))))
+ (let ((ab (slot-boundp a slot))
+ (bb (slot-boundp b slot)))
+ (cond ((and ab bb) (same (slot-value a slot)
+ (slot-value b slot)))
+ ((or ab bb) nil)
+ (t t))))
(defun slots= (a b &rest slots)
- (every (alexandria:curry #'slot= a b) slots))
+ (and (eql (class-of a) (class-of b))
+ (every (alexandria:curry #'slot= a b) slots)))
(defun check-reads-one-object (object string)
@@ -423,11 +426,9 @@
(foos :json (vector foo) :initarg :foos))
(:metaclass jarl:json-class))
-(defun foo (&rest args)
- (apply #'make-instance 'foo args))
-(defun bar (&rest args)
- (apply #'make-instance 'bar args))
+(defun foo (&rest args) (apply #'make-instance 'foo args))
+(defun bar (&rest args) (apply #'make-instance 'bar args))
(defmethod same ((a foo) (b foo))
(slots= a b 'i 's 'k 'n 'h 'v 'any))
@@ -476,6 +477,45 @@
(jarl:print (make-instance 'foo :v #(1 2 3)) nil)))))
+;;;; Slot Coalescing ----------------------------------------------------------
+(defclass coal/0 ()
+ ((foo :json number :initarg :foo)
+ (bar :json string :json/name "bar0" :initarg :bar))
+ (:metaclass jarl:json-class))
+
+(defclass coal/1 (coal/0)
+ ((foo :json string)
+ (bar :json/name "bar1"))
+ (:metaclass jarl:json-class))
+
+(defclass coal/2 (coal/1)
+ ((foo))
+ (:metaclass jarl:json-class))
+
+
+(defun coal/0 (&rest args) (apply #'make-instance 'coal/0 args))
+(defun coal/1 (&rest args) (apply #'make-instance 'coal/1 args))
+(defun coal/2 (&rest args) (apply #'make-instance 'coal/2 args))
+
+
+(defmethod same ((a coal/0) (b coal/0)) (slots= a b 'foo 'bar))
+(defmethod same ((a coal/1) (b coal/1)) (slots= a b 'foo 'bar))
+(defmethod same ((a coal/2) (b coal/2)) (slots= a b 'foo 'bar))
+
+
+(define-test slot-coalescing-json-class
+ ;; More-specific classes should take precedence.
+ (is (same (coal/0 :foo 1) (jarl:read 'coal/0 (json "{'foo': 1}"))))
+ (is (same (coal/1 :foo "meow") (jarl:read 'coal/1 (json "{'foo': 'meow'}"))))
+ (is (same (coal/2 :foo "meow") (jarl:read 'coal/2 (json "{'foo': 'meow'}")))))
+
+(define-test slot-coalescing-json-name
+ ;; More-specific names should take precedence.
+ (is (same (coal/0 :bar "x") (jarl:read 'coal/0 (json "{'bar0': 'x'}"))))
+ (is (same (coal/1 :bar "x") (jarl:read 'coal/1 (json "{'bar1': 'x'}"))))
+ (is (same (coal/2 :bar "x") (jarl:read 'coal/2 (json "{'bar1': 'x'}")))))
+
+
;;;; Wrappers -----------------------------------------------------------------
(defclass w ()
((names :type list :initarg :names)))
@@ -521,6 +561,25 @@
(:metaclass jarl:json-class)
(:allow-print nil))
+(defclass apr/sub (apr)
+ ()
+ (:metaclass jarl:json-class))
+
+(defclass apr/sub/remove (apr/sub)
+ ()
+ (:metaclass jarl:json-class)
+ (:allow-print nil)
+ (:allow-read nil))
+
+(defclass apr/sub/remove/sub (apr/sub/remove)
+ ()
+ (:metaclass jarl:json-class))
+
+(defclass apr/sub/add (apr/sub/remove)
+ ()
+ (:metaclass jarl:json-class)
+ (:allow-print t)
+ (:allow-read t))
(define-test allow-read
(is (= 1 (slot-value (jarl:read 'apr (json "{'id': 1}")) 'id)))
@@ -532,6 +591,28 @@
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/deny-read :id 1) nil)))
(signals error (jarl:print (make-instance 'apr/deny-print :id 1) nil)))
+(define-test allow-read-inheritance
+ (is (= 1 (slot-value (jarl:read 'apr (json "{'id': 1}")) 'id)))
+ ;; Subclassing without overriding inherits.
+ (is (= 1 (slot-value (jarl:read 'apr/sub (json "{'id': 1}")) 'id)))
+ ;; Remove, can no longer read.
+ (signals error (jarl:read 'apr/sub/remove (json "{'id': 1}")))
+ ;; Can inherit the removal.
+ (signals error (jarl:read 'apr/sub/remove/sub (json "{'id': 1}")))
+ ;; Readd, can print again.
+ (is (= 1 (slot-value (jarl:read 'apr/sub/add (json "{'id': 1}")) 'id))))
+
+(define-test allow-print-inheritance
+ (is (string= (json "{'id':1}") (jarl:print (make-instance 'apr :id 1) nil)))
+ ;; Subclassing without overriding inherits.
+ (is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/sub :id 1) nil)))
+ ;; Remove, can no longer read.
+ (signals error (jarl:print (make-instance 'apr/sub/remove :id 1) nil))
+ ;; Can inherit the removal.
+ (signals error (jarl:print (make-instance 'apr/sub/remove/sub :id 1) nil))
+ ;; Readd, can print again.
+ (is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/sub/add :id 1) nil))))
+
;;;; After Read/Before Print --------------------------------------------------
(define-condition validation-error (error) ())