moptilities.lisp

;;;; ENSURE-SUPERCLASS-MIXIN
;;;
;;; Example usage:
;;;
;;;   (defclass foo () ())
;;;
;;;   (defclass my-metaclass (ensure-superclass-mixin standard-class)
;;;     ()
;;;     (:default-initargs
;;;      :ensured-superclasses '(foo)))
;;;
;;;   (defclass bar ()
;;;     ()
;;;     (:metaclass my-metaclass))
;;;
;;;   (subtypep 'bar 'foo) => T, T

(defclass ensure-superclass-mixin (standard-class)
  ((ensured-superclasses :accessor ensured-superclasses :initform '()))
  (:documentation
   "User metaclasses can inherit this mixin in order to ensure
   that instances of those metaclasses have certain classes in
   their superclasses graph."))

(defun superclass-p (class-name class-list)
  "Returns T if one of the classes in CLASS-LIST subclasses the
  class designated by CLASS-NAME."
  (let ((class-object (find-class class-name)))
    (loop for class in class-list
          thereis (subtypep class class-object))))

(defun ensure-superclasses (call-next-method class initargs)
  (let* ((direct-superclasses (getf initargs :direct-superclases))
         (missing (loop for super in (ensured-superclasses class)
                        unless (superclass-p super direct-superclasses)
                        collect super)))
    (apply call-next-method
           class
           :direct-superclasses
           (append direct-superclasses
                   (mapcar #'find-class missing))
           initargs)))

(defmethod initialize-instance :around
    ((self ensure-superclass-mixin) &rest initargs &key ensured-superclasses
     &allow-other-keys)
  "Ensure SELF has ENSURED-SUPERCLASSES in its superclasses."
  (setf (ensured-superclasses self) ensured-superclasses)
  (ensure-superclasses #'call-next-method self initargs))

(defmethod reinitialize-instance :around
    ((self ensure-superclass-mixin) &rest initargs
     &key (direct-superclasses '() direct-superclasses-p)
     (ensured-superclasses '() ensured-superclasses-p)
     &allow-other-keys)
  "Ensure SELF has (ENSURED-SUPERCLASSES SELF) in its superclasses"
  (declare (ignore direct-superclasses))
  (when ensured-superclasses-p
    (setf (ensured-superclasses self) ensured-superclasses))
  (if (not direct-superclasses-p)
      (call-next-method)
      (ensure-superclasses #'call-next-method self initargs)))

;;;; DEFINE-CUSTOM-SLOT-DEFINITION
;;;
;;; Very ad-hoc abstraction of the common use case of adding new slot
;;; definition options that map directly to the effective slot
;;; definition.
;;;
;;; Example usage:
;;;
;;;   (define-custom-slot-definition my-meta-class ()
;;;     (special-option1 :initarg :special-option1 :initform nil
;;;                      :reader special-option1
;;;     (special-option2 :initarg :special-option2 :initform nil
;;;                      :reader special-option2))
;;;
;;;   (defclass foo ()
;;;     ((bar :special-option1 quux))
;;;     (:metaclass my-meta-class))
;;;
;;;   (special-option1 (car (class-slots (find-class 'foo))
;;;   => QUUX

(defmacro define-custom-slot-definition (metaclass options &body slots)
  (declare (ignore options))
  (let ((dsd-classname (symbolicate metaclass '#:-direct-slot-definition))
        (esd-classname (symbolicate metaclass '#:-effective-slot-definition)))
    `(progn
       ;; Slot definitions.
       (defclass ,dsd-classname (standard-direct-slot-definition)
         ,slots)
       (defmethod direct-slot-definition-class ((class ,metaclass) &key)
         (find-class ',dsd-classname))
       (defclass ,esd-classname (standard-effective-slot-definition)
         ,slots)
       (defmethod effective-slot-definition-class ((class ,metaclass) &key)
         (find-class ',esd-classname))
       ;; Slot computation.
       (defmethod compute-effective-slot-definition
           ((class ,metaclass) slot-name direct-slot-definitions)
         (declare (ignore slot-name))
         (let ((effective-slotd (call-next-method)))
           ,@(loop for slotd in (mapcar (compose #'car #'ensure-list) slots)
                   collect `(setf (slot-value effective-slotd ',slotd)
                                  (slot-value (first direct-slot-definitions)
                                              ',slotd)))
           effective-slotd)))))