# HG changeset patch # User Steve Losh # Date 1608008628 18000 # Node ID 04933ed075967b0f8469b71999e95832a9695bfc # Parent 693b1dfe357aee4f61103a86eb433b463fcd752a Clean up slot option and class option coalescence diff -r 693b1dfe357a -r 04933ed07596 .TODO.done --- 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 diff -r 693b1dfe357a -r 04933ed07596 TODO --- 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 diff -r 693b1dfe357a -r 04933ed07596 src/mop.lisp --- 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)) diff -r 693b1dfe357a -r 04933ed07596 test/tests.lisp --- 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) ())