# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1626396871 14400
# Node ID e94de54baaa113eae17919cb2cfa641b929f2cf5
# Parent  04933ed075967b0f8469b71999e95832a9695bfc
Clean up superclass bugs

diff -r 04933ed07596 -r e94de54baaa1 .TODO.done
--- 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
diff -r 04933ed07596 -r e94de54baaa1 TODO
--- 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
diff -r 04933ed07596 -r e94de54baaa1 src/mop.lisp
--- 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 ---------------------------------------------------------------------