A metaclass for weblocks-webapps, try 3

This one includes mostly the same shared-initialize and defwebapp contents, but updated for some new changes to dev.

It introduces the :reset slot option, which follows a leftmost-bound inheritance rule and specifies that shared-initialize should ignore its second argument for that slot, always assuming the slot should be initialized.

For weblocks-webapp in particular, it has the problem that for slots provided with :reset t, it would be necessary to export the slot names, so that subclasses could cancel the behavior. It also has the problem that values initialized or normalized by initializer methods are not recognized as reproducible initial values.

(defclass weblocks-webapp-class (standard-class)
  ()
  (:documentation "Class of all classes created by `defwebapp'.  The
  really interesting behavior is in
  `shared-initialize' (weblocks-webapp t &rest)."))

(defmethod validate-superclass ((class weblocks-webapp-class) superclass)
  (typep (class-name (class-of superclass))
         '(member standard-class weblocks-webapp-class)))

(defgeneric slot-definition-reset-p (slot-defn)
  (:documentation "Answer whether to change the value of this slot
   when reinitializing or updating an instance after class
   redefinition.")
  (:method ((slot-defn slot-definition))
    "Regardless of this method, only direct-slot-definitions where
    `resetp' is a bound slot may participate in the inheritance rule."
    nil))

(defgeneric (setf slot-definition-reset-p) (value slot-defn)
  (:documentation "See `slot-definition-reset-p'."))

(defclass resetting-slot-definition (slot-definition)
  ((resetp :initarg :reset :accessor slot-definition-reset-p))
  (:documentation "I provide the extension that when `resetp' is
  non-nil, and an initarg is not present in the `shared-initialize'
  call, I will use a relevant stored initarg or initfunction to reset
  my value.

  :reset's inheritance rule is leftmost-bound."))

(defclass resetting-eslot-definition
    (resetting-slot-definition standard-effective-slot-definition)
  ())

(defclass resetting-dslot-definition
    (resetting-slot-definition standard-direct-slot-definition)
  ())

(defmethod direct-slot-definition-class
    ((self weblocks-webapp-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'resetting-dslot-definition))

(defmethod effective-slot-definition-class
    ((self weblocks-webapp-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'resetting-eslot-definition))

(defun compute-resetting-eslot-definition (eslot class name dslotds)
  "Implement leftmost-bound rule for resetp."
  (declare (ignore name))
  (setf (slot-definition-reset-p eslot)
        (and-let* ((leftmost-bound (find-if (lambda (dslot)
                                              (and (slot-exists-p dslot 'resetp)
                                                   (slot-boundp dslot 'resetp)))
                                            dslotds)))
          (slot-definition-reset-p leftmost-bound)))
  eslot)

(defmethod compute-effective-slot-definition ((self weblocks-webapp-class) name dslotds)
  (compute-resetting-eslot-definition (call-next-method) self name dslotds))

(defun reset-slots (instance initargs)
  "Given an instance to be initialized and the initargs passed to the
initializer method, reset the appropriate slots to their original
values."
  (dolist (eslot (class-slots (class-of instance)))
    (when (slot-definition-reset-p eslot)
      (let ((initkeys (slot-definition-initargs eslot)))
        (when (loop for (key) on initargs by #'cddr
                    never (member key initkeys))
          (flet ((set-it (val)
                   (setf (slot-value instance (slot-definition-name eslot)) val)))
            (or (and-let* (initkeys
                           (definit
                            (some (lambda (definit) (member (car definit) initkeys))
                                  (class-default-initargs (class-of instance)))))
                  (set-it (funcall (third definit)))
                  t)
                (and-let* ((initfunc (slot-definition-initfunction eslot)))
                  (set-it (funcall initfunc))
                  t))))))))

Where shared-initialize calls reset-slots when its second argument is not t (as is required for initialize-instance).

Notwithstanding the above issues, the real difficulty forcing me to abandon this particular iteration for now is that the test failures in dev have jumped from 9 (at last pull from c6dc18-test-fixes) to over 90. I'm sure this has to do with the current defwebapp implementation having dependency issues eerily similar to that mentioned in my last post.

By the time I reached this conclusion, I had been too frustrated by fighting with SBCL and SLIME on OS X to do anything about it. Later today, I'll just boot up in GNU/Linux, wifi be damned.

Next up, doing as much as I can without the metaclass, just so other dev writers will put more new instance logic in the initialize method instead of defwebapp. Then I can revisit the metaclass issue with a fresh look, something like this:

(defclass a-class (s-class)
  ()
  (:persistent-initargs :a :b :c)
  (:transient-initargs :d :e :f))

…where some initializer method will capture all initargs (not initforms this time, I think), including those given to make-instance, storing in an instvar, and initarg semantics are determined by a leftmost-persistent-or-transient rule. This has the benefit of not killing initializer method settings with the common :initform nil.

Or, I'll be back here later with an explanation of why it won't work.