defclass options slay me, again

I previously wrote about missing canonicalize-defclass-options. Now I have a nice inconsistency in AMOP to add to the complaints.

I have believed for some time, for some reason, that this is the standard slot option canonicalizer, excepting the special cases:

(defun canonicalize-defclass-option (opt)
`(',(car opt)
  ',(if (typep (cdr opt) '(cons t null))
      (cadr opt)
      (cdr opt))))

In other words, if you gave a single argument, like (:opt val), it wouldn't be listified. A little weird, with a nasty special case, but a good attempt at dealing with both listy and atomy class options.

Thankfully, AMOP has two contradictory interpretations, neither of which are the above. First, the example on page 287, which would have it:

  `(',(car opt)
   ',(cadr opt))

Finally, on page 148, hiding from the prying eyes of back-of-the-book indexed content (nowhere near the entries on defclass), the true behavior:

Any other class options become the value of keyword arguments with the same name. The value of the keyword argument is the tail of the class option.

  `(',(car opt)
   ',(cdr opt))

I also previously thought the defclass options to be evaluated, but never mind that.

Dependencies versus effort

I do not need to rehash the benefits of relying on other libraries when developing a library here. If you care about dependencies, you ought to be familiar with those benefits already.

I wish to instead address the common complaint of "too many dependencies" from those who feel that getting a Common Lisp library installed is too difficult.

Here is how I feel about such requests:



In short, the effort avoiding a dependency, even in the case of synchronizing with an external source, far exceeds that for the simple process of fetching a dependency yourself and adding it to your ASDF registry. What's good for the maintainer is good for the library.

To clarify further:

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.

A metaclass for weblocks-webapps, try 2

My next attempt was more interesting, succeeding in point #1, and getting around point #2 with a new slot definition feature.

Unfortunately, at this point, I ran into the default canonicalization behavior for slots and defclass options. While AMOP discusses a possible extension via a generic function canonicalize-defclass-options, it is unfortunately not included in the final MOP. So:

1. Except for :default-initargs, class options are always quoted.


2. Except for :initform, slot options are always quoted.

That and a dependency issue forced me to abandon this try, which introduces the instance initfunction to address the common complaint about initforms that the expression cannot refer to the new instance.

(defmacro and-let* ((&rest bindings) &body body)
  "Like `let*', but stop when encountering a binding that evaluates to
NIL.  Also allows (EXPR), stopping when EXPR is false, and EXPR as a
shortcut for it only if EXPR is a symbol."
  (reduce (lambda (binding body)
            (etypecase binding
              (symbol `(and ,binding ,body))
              ((cons symbol (cons t null))
               `(let (,binding)
                  (and ,(car binding)
                       ,body)))
              ((cons t null)
               `(and ,(car binding) ,body))))
          bindings :from-end t :initial-value (cons 'progn body)))

(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)))

(defclass instance-initializing-slot-definition (slot-definition)
  ((instance-initfunction :initarg :instance-initfunction :initform nil
                          :accessor slot-definition-instance-initfunction))
  (:documentation "I provide an alternative to `:initform' for slots,
  the `:instance-initfunction', a function taking the instance to be
  initialized."))

(defclass weblocks-webapp-direct-slot-definition
    (instance-initializing-slot-definition standard-direct-slot-definition)
  ()
  (:documentation "Direct slot definition for `weblocks-webapp-class'es."))

(defclass weblocks-webapp-effective-slot-definition
    (instance-initializing-slot-definition standard-effective-slot-definition)
  ()
  (:documentation "Effective slot definition for `weblocks-webapp-class'es."))

(defmethod compute-effective-slot-definition
    ((self weblocks-webapp-class) name direct-slot-defns)
  "Transfer `instance-initfunction' to the effective slot definition,
making sure to override the regular `initfunction' if mine appears
first in the precedence list, so `shared-initialize' will not call it
to fill the slot."
  (let ((eslot (call-next-method)))
    (loop for (dslot . slot-precedence) on direct-slot-defns
          when (slot-definition-initfunction eslot)
            do (return)
          when (and (slot-exists-p self 'instance-initfunction)
                    (slot-definition-instance-initfunction dslot))
            do (setf (slot-definition-instance-initfunction eslot)
                     (slot-definition-instance-initfunction dslot)
                     (slot-definition-initfunction eslot) nil
                     (slot-definition-initform eslot) nil)
               (return))
    eslot))

(defmethod direct-slot-definition-class
    ((self weblocks-webapp-class) &rest initargs)
  "Use my special version when `:instance-initfunction' is present."
  (if (getf initargs :instance-initfunction)
      (find-class 'weblocks-webapp-direct-slot-definition)
      (call-next-method)))

(defmethod effective-slot-definition-class
    ((self weblocks-webapp-class) &rest initargs)
  "As `instance-initfunction' is transferred over later, it isn't
present in INITARGS, so assume any slot might need it."
  (declare (ignore initargs))
  (find-class 'weblocks-webapp-effective-slot-definition))

(defun instance-initialize-unbound-slots (self slot-names)
  "Do the magic promised by `weblocks-webapp-class'."
  (let ((slots (class-slots (find-class self))))
    (dolist (slot slot-names)
      (and-let* (((not (slot-boundp self slot)))
                 (slotd (find slot slots :key #'slot-definition-name))
                 (initfunc (slot-definition-instance-initfunction slotd)))
        (setf (slot-value self slot)
              (funcall initfunc self))))))

(defmethod shared-initialize :after ((self weblocks-webapp-class) slot-names
                                     &key &allow-other-keys)
  (declare (ignore slot-names))
  (pushnew (class-name self) *registered-webapps*))

(defclass weblocks-webapp ()
  ((name :accessor weblocks-webapp-name :initarg :name :type string
         :instance-initfunction (lambda (self)
                                  (attributize-name (class-name (class-of self)))))
   ;;snip uninteresting slots
   (prefix :accessor weblocks-webapp-prefix :initarg :prefix :initform ""
           :instance-initfunction
           (lambda (self)
             (concatenate 'string "/" (weblocks-webapp-name self)))
           :type string
           :documentation "The default dispatch will allow a webapp to be invoked 
              as a subtree of the URI space at this site.  This does not support 
              webapp dispatch on virtual hosts, browser types, etc.")
   ;;snip more
   (init-user-session :accessor weblocks-webapp-init-user-session :initarg :init-user-session
                      :instance-initfunction
                      (lambda (self)
                        (find-symbol (symbol-name '#:init-user-session)
                                     (symbol-package (class-name (class-of self)))))
                      :type symbol
                      :documentation "'init-user-session' must be defined by weblocks client in the
                         same package as 'name'. This function will accept a single parameter - a 
                         composite widget at the root of the application. 'init-user-session' is 
                         responsible for adding initial widgets to this composite.")
   (ignore-default-dependencies
    :initform nil :initarg :ignore-default-dependencies
    :documentation "Inhibit appending the default dependencies to
the dependencies list.  By default 'defwebapp' adds the following resources:

  Stylesheets: layout.css, main.css
  Scripts: prototype.js, weblocks.js, scriptaculous.js")
   (debug :accessor weblocks-webapp-debug :initarg :debug :initform nil))
  (:metaclass weblocks-webapp-class)
  (:documentation "snip"))

(defmacro defwebapp (name &rest initargs &key subclasses slots (autostart t)
                     &allow-other-keys)
  "snip"
  (remf initargs :subclasses)
  (remf initargs :slots)
  (remf initargs :autostart)
  `(prog1
     (defclass ,name ,(append subclasses (list 'weblocks-webapp))
       ,slots
       (:default-initargs . ,initargs)
       (:metaclass weblocks-webapp-class))
    (when autostart
      (pushnew ',name *autostarting-webapps*))))

(defmethod shared-initialize ((self weblocks-webapp) slot-names
                              &key &allow-other-keys)
  "Use my `instance-initfunction' to initialize any slots that aren't
yet bound."
  (instance-initialize-unbound-slots self slot-names)
  (macrolet ((do-slot ((bind-var &optional (slot-name bind-var)) &body forms)
               `(when (member ',slot-name slot-names)
                  (let ((,bind-var (slot-value self ',slot-name)))
                    ,@forms))))
    (do-slot (init-user-session)
      (or init-user-session
          (error (format nil "Cannot initialize application ~A because no~
                              init-user-session function is found."
                         (webapp-name self)))))
    (when (member 'application-dependencies slot-names)
      (setf (weblocks-webapp-application-dependencies self)
            (build-local-dependencies
             (append (and (not (slot-value self 'ignore-default-dependencies))
                          '((:stylesheet "layout")
                            (:stylesheet "main")
                            (:stylesheet "dialog")
                            (:script "prototype")
                            (:script "scriptaculous")
                            (:script "shortcut")
                            (:script "weblocks")
                            (:script "dialog")))
                     dependencies))))
    (do-slot (path public-app-path)
      (setf (weblocks-webapp-public-app-path self)
            (if (or (null path) (eq path :system-default))
                nil
                (compute-public-files-path 
                 (intern (package-name (class-name (class-of self))) :keyword)))))))

Even without the quoting problem, the fact that prefix's initfunction requires name's initfunction to be called first means that I would need to introduce dependency analysis and expression. But Kenny has already solved this problem.

A metaclass for weblocks-webapps

defwebapp in weblocks-dev currently does many mysterious things with its keyword arguments. But these are the sorts of things that should be given directly to make-instance, so that you can use your own defclass forms and your own make-instance calls to construct weblocks-webapp instances in creative ways.

I have a few goals for a rewrite of defwebapp:

1. Trivialize the mapping of the defwebapp form to a defclass form, putting most of the logic in initializing methods and possibly a metaclass (ahem, class metaobject class).
2. Don't hide the default slot values in class-default-initargs.
   
3. On reevaluation of defwebapp, replace the slot values, at least in the trivial case where the hacker allowed the normal autostarter to instantiate the resulting weblocks-webapp subclass.
   

My first thought, abandoned before I could even start changing defwebapp proper to use it, would have defwebapp fill class-instance slots (not to be confused with instance slots with :allocation :class) instead of default-initargs, then alter the initform and initfunction in compute-effective-slot-definition to copy over those values to each new instance.

(defclass weblocks-webapp-class (standard-class)
  ())

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

(defgeneric class-defaulting-slots (class)
  (:method ((self weblocks-webapp-class))
    (loop for class in (class-precedence-list self)
       while (typep class 'weblocks-webapp-class)
       append (class-direct-slots class)))
  (:method ((self standard-class)) '()))

(defmethod compute-effective-slot-definition
    ((self weblocks-webapp-class) name direct-slot-defns)
  "Provide a default initform (read the class's version of the slot)
for those without initforms."
  (let ((eslot (call-next-method))
        (defaulting-slots (class-defaulting-slots self)))
    (macrolet ((initfunc () (slot-definition-initfunction eslot)))
      (when (and (find name defaulting-slots :key #'slot-definition-name)
                 (not (initfunc)))
        (setf (slot-definition-initform eslot)
              `(slot-value (find-class ',(class-name self)) ',name)
              (initfunc) (lambda () (slot-value self name)))))
    eslot))