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.