--- a/.TODO.done Tue Dec 15 00:03:48 2020 -0500
+++ b/.TODO.done Thu Jul 15 20:54:31 2021 -0400
@@ -2,6 +2,7 @@
Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04
Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
+Move json class option coalescence from shared-initialize into the other functions as a hack. | id:554da97518957275704b33267a5d3d597092d037
Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58
Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
--- a/TODO Tue Dec 15 00:03:48 2020 -0500
+++ b/TODO Thu Jul 15 20:54:31 2021 -0400
@@ -1,3 +1,5 @@
+Have a separate class for non-slot-preserving JSON objects to save a slot. | id:7c42071fe13dc0ff13241a3a3fd0cbabe2ca81cd
Write documentation. | id:8612eacd92edd0b4b196feb5d084d58e86cedeeb
+Add INTEGER as a separate readable class. | id:9ced2460eb2927a1b4299d5d189ee5cc77eecf19
Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/src/mop.lisp Tue Dec 15 00:03:48 2020 -0500
+++ b/src/mop.lisp Thu Jul 15 20:54:31 2021 -0400
@@ -1,8 +1,35 @@
(in-package :jarl)
-;;;; Object Parsers -----------------------------------------------------------
+;;;; Dependents Maintenance ---------------------------------------------------
+;;; We need to use the MOP dependent maintenance protocol to recompute any
+;;; defaulted class options when a superclass changes.
+
+(defclass json-dependent ()
+ ((dep :accessor dep :initarg :dep)))
+
+(defun dep= (d class)
+ ;; We need to filter out any other dependents other code might have added.
+ (and (typep d 'json-dependent)
+ (eql (dep d) class)))
+
+(defun ensure-dep (superclass class)
+ (c2mop:map-dependents superclass
+ (lambda (d)
+ (when (dep= d class)
+ (return-from ensure-dep))))
+ (c2mop:add-dependent superclass (make-instance 'json-dependent :dep class)))
+
+(defun ensure-no-dep (superclass class)
+ (c2mop:map-dependents superclass
+ (lambda (d)
+ (when (dep= d class)
+ (c2mop:remove-dependent superclass d)
+ (return-from ensure-no-dep)))))
+
+
+;;;; JSON Metaclass -----------------------------------------------------------
(defun lisp-case-to-snake-case (string)
- "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
+ "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake-cased `\"foo_bar\"`."
(substitute #\_ #\- (string-downcase string)))
@@ -10,16 +37,20 @@
((preserved :accessor preserved :initarg preserved)))
(defclass json-class (standard-class)
- ((slot-name-to-json-name :accessor slot-name-to-json-name
- :initarg :slot-name-to-json-name
- :initform 'lisp-case-to-snake-case)
+ ((given-unknown-slots)
+ (given-slot-name-to-json-name)
+ (given-allow-print)
+ (given-allow-read)
(unknown-slots :accessor unknown-slots
:initarg :unknown-slots
:initform :discard)
+ (slot-name-to-json-name :accessor slot-name-to-json-name
+ :initarg :slot-name-to-json-name
+ :initform 'lisp-case-to-snake-case)
+ (allow-print :accessor allow-print :initarg :allow-print :initform t)
+ (allow-read :accessor allow-read :initarg :allow-read :initform t)
(slot-map :accessor slot-map)
- (slot-alist :accessor slot-alist)
- (allow-print :accessor allow-print :initarg :allow-print :initform t)
- (allow-read :accessor allow-read :initarg :allow-read :initform t)))
+ (slot-alist :accessor slot-alist)))
(defun json-class-p (object)
(typep object 'json-class))
@@ -63,11 +94,9 @@
;; If none of the direct slots have an initarg, we'll gensym one. Otherwise
;; we can use an existing one and not clutter things up.
(apply #'call-next-method class
- (append
- (when (null initargs)
- (list :initargs
- (list (gensym (string name)))))
- args)))
+ (append (when (null initargs)
+ (list :initargs (list (gensym (string name)))))
+ args)))
(defun plist-keys (plist)
@@ -98,6 +127,20 @@
(if ,found ,result ,default))))
(defun coalesce-most-specific-value (dslots slot-name)
+ "Coalesce the most-specific value of `slot-name` from the JSON direct slots.
+
+ Given a list of JSON direct slot definitions for a particular slot `foo`:
+
+ ((foo :json/name \"x\") ; sub sub
+ (foo :json/name \"x\") ; sub
+ (foo :json string)) ; super
+
+ Return the most-specific slot value for the given slot name (e.g. \"x\" in
+ this example), or `nil` if none is found.
+
+ Also returns `t` as a second value if a value was found.
+
+ "
(dolist (dslot dslots (values nil nil))
(when (slot-boundp dslot slot-name)
(return (values (slot-value dslot slot-name) t)))))
@@ -153,49 +196,6 @@
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)
- ;; 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)
"Patch `direct-superclasses` to ensure `json-object` will be a superclass.
@@ -210,24 +210,130 @@
direct-superclasses
(append direct-superclasses (list super)))))
+(defun recompute-slot (&key class superclasses slot given-slot value value? default)
+ "Set the metaclass' slot to the appropriate value.
+
+ For metaclass slots like `:allow-print`, if the user provides an explicit
+ value it will be used, otherwise the value will be inherited from any
+ superclass' value, otherwise the default will be used.
+
+ In any case, the computed value is stored in the slot, and the original
+ user-given value (if any) is stored in the `given-…` slot so we can use it
+ later if any superclasses change and we need to recompute this.
+
+ "
+ (setf superclasses (remove-if-not #'json-class-p superclasses))
+ ;; We need to store whether the user gave an explicit value for later.
+ (if value?
+ (setf (slot-value class given-slot) value)
+ (slot-makunbound class given-slot))
+ ;; Set the actual value to the given value, or the superclass value, or the default.
+ (setf (slot-value class slot)
+ (cond
+ (value? (progn (when (/= 1 (length value))
+ (error "fuck u"))
+ (first value)))
+ (superclasses (slot-value (first superclasses) slot))
+ (t default))))
+
+(defun recompute-slots (class &key
+ direct-superclasses
+ (slot-name-to-json-name nil slot-name-to-json-name?)
+ (unknown-slots nil unknown-slots?)
+ (allow-read nil allow-read?)
+ (allow-print nil allow-print?)
+ &allow-other-keys)
+ (recompute-slot :class class :superclasses direct-superclasses
+ :slot 'slot-name-to-json-name :given-slot 'given-slot-name-to-json-name
+ :value slot-name-to-json-name :value? slot-name-to-json-name?
+ :default #'lisp-case-to-snake-case)
+ (recompute-slot :class class :superclasses direct-superclasses
+ :slot 'unknown-slots :given-slot 'given-unknown-slots
+ :value unknown-slots :value? unknown-slots?
+ :default :discard)
+ (recompute-slot :class class :superclasses direct-superclasses
+ :slot 'allow-print :given-slot 'given-allow-print
+ :value allow-print :value? allow-print?
+ :default t)
+ (recompute-slot :class class :superclasses direct-superclasses
+ :slot 'allow-read :given-slot 'given-allow-read
+ :value allow-read :value? allow-read?
+ :default t))
+
+(defun strip-initargs (initargs)
+ "Remove any JSON class initargs from `initargs`.
+
+ We need to do this because we handle these ourselves before `call-next-method`,
+ in `recompute-slots`, and if we leave them in the initarg list then
+ `call-next-method` will happily overwrite all that hard work we just did.
+
+ "
+ (loop
+ :for (initarg value) :on initargs :by #'cddr
+ :unless (member initarg
+ '(:allow-print :allow-read :unknown-slots :slot-name-to-json-name))
+ :append (list initarg value)))
+
(defmethod initialize-instance :around
- ((class json-class) &rest initargs
- &key direct-superclasses &allow-other-keys)
- ;;; I have no idea why doing this once in shared-initialize works in SBCL but
- ;;; not in CCL/ECL. Oh well. This solution from https://www.cliki.net/MOP%20design%20patterns
- ;;; seems to work everywhere.
+ ((class json-class) &rest initargs &key
+ direct-superclasses
+ &allow-other-keys)
+ (apply #'recompute-slots class initargs)
(apply #'call-next-method class
:direct-superclasses (patch-direct-superclasses direct-superclasses)
- initargs))
+ (strip-initargs initargs))
+ ;; You might think we could get away with only having dependencies on
+ ;; superclasses that happen to be our specific metaclass, instead of on ALL
+ ;; direct superclasses. Sadly this fails for forward-referenced classes, so
+ ;; we need to add dependencies on all of them and filter out the non-MC
+ ;; classes later.
+ (dolist (superclass (c2mop:class-direct-superclasses class))
+ (ensure-dep superclass class)))
(defmethod reinitialize-instance :around
- ((class json-class) &rest initargs
- &key (direct-superclasses nil direct-superclasses?) &allow-other-keys)
- (if direct-superclasses?
+ ((class json-class) &rest initargs
+ &key (direct-superclasses nil direct-superclasses?) &allow-other-keys)
+ ;; We have to recompute slots /before/ we call-next-method because the
+ ;; update-dependent calls happen as part of that next method. If we wait
+ ;; until after call-next-method to patch up X, then the dependent will still
+ ;; see the old version when it's updated and won't get the new value until
+ ;; a second round of initialization.
+ (apply #'recompute-slots class
+ :direct-superclasses (if direct-superclasses?
+ direct-superclasses
+ (c2mop:class-direct-superclasses class))
+ initargs)
+ (let ((before (c2mop:class-direct-superclasses class)))
(apply #'call-next-method class
- :direct-superclasses (patch-direct-superclasses direct-superclasses)
- initargs)
- (call-next-method)))
+ (append (when direct-superclasses?
+ (list :direct-superclasses
+ (patch-direct-superclasses direct-superclasses)))
+ (strip-initargs initargs)))
+ (let* ((after (c2mop:class-direct-superclasses class))
+ (removed (set-difference before after))
+ (added (set-difference after before)))
+ (dolist (superclass removed)
+ (ensure-no-dep superclass class))
+ (dolist (superclass added)
+ (ensure-dep superclass class)))))
+
+(defun given-to-initarg (class initarg given-slot)
+ (when (slot-boundp class given-slot)
+ (list initarg (slot-value class given-slot))))
+
+(defmethod c2mop:update-dependent (obj (dep json-dependent) &rest initargs)
+ (declare (ignore initargs))
+ (when (json-class-p obj) ; We can ignore changes in non-JSON superclasses here.
+ ;; We need to call reinitialize-instance here (instead of just recomputing
+ ;; the slots) because otherwise transitive dependencies won't get updated
+ ;; properly.
+ (let ((class (dep dep)))
+ (apply #'reinitialize-instance class
+ (append
+ (given-to-initarg class :slot-name-to-json-name 'given-slot-name-to-json-name)
+ (given-to-initarg class :unknown-slots 'given-unknown-slots)
+ (given-to-initarg class :allow-print 'given-allow-print)
+ (given-to-initarg class :allow-read 'given-allow-read))))))
;;;; Read ---------------------------------------------------------------------