[lisp] / mdw-mop.lisp

;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Useful bits of MOP hacking
;;;
;;; (c) 2006 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;; 
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;;--------------------------------------------------------------------------
;;; Packages.

(defpackage #:mdw.mop
  (:use #:common-lisp #:mdw.base #+cmu #:pcl)
  (:export #:compatible-class
           #:initargs-for-effective-slot #:make-effective-slot
           #:filtered-slot-class-mixin
             #:filtered-direct-slot-definition
             #:filtered-effective-slot-definition
           #:predicate-class-mixin
           #:abstract-class-mixin #:instantiate-abstract-class
           #:mdw-class #:abstract-class
           #:print-object-with-slots))

(in-package #:mdw.mop)

;;;--------------------------------------------------------------------------
;;; Basic stuff.

(defclass compatible-class (standard-class)
  ()
  (:documentation
   "A class which can be be freely used in class heirarchies with
    standard-class and other subclasses of compatible-class.  This saves a
    bunch of annoying messing about with `validate-superclass'."))

(defmethod validate-superclass
    ((sub compatible-class) (super compatible-class))
  t)

(defmethod validate-superclass
    ((sub compatible-class) (super standard-class))
  (eq (class-of super) (find-class 'standard-class)))

(defmethod validate-superclass
    ((sub standard-class) (super compatible-class))
  (eq (class-of sub) (find-class 'standard-class)))

;;;--------------------------------------------------------------------------
;;; Utilities for messing with slot options.

(defgeneric initargs-for-effective-slot (class direct-slots)
  (:documentation
   "Missing functionality from the MOP: given a class and its direct slots
    definitions, construct and return the proposed initializer list for
    constructing the effective-slot."))

(defmethod initargs-for-effective-slot
    ((class standard-class) direct-slots)
  "Extract the effective slot options as required."
  ;;
  ;; This is taken from the Closette implementation, but it seems to work!
  (let ((init-slot (find-if-not #'null direct-slots
                                :key #'slot-definition-initfunction)))
    (list :name (slot-definition-name (car direct-slots))
          :initform (and init-slot
                         (slot-definition-initform init-slot))
          :initfunction (and init-slot
                             (slot-definition-initfunction init-slot))
          :initargs (remove-duplicates
                     (apply #'append
                            (mapcar #'slot-definition-initargs
                                    direct-slots)))
          :allocation (slot-definition-allocation (car direct-slots)))))

(defun make-effective-slot (class initargs)
  "Construct an effectie slot definition for a slot on the class, given the
   required arguments."
  (apply #'make-instance
         (apply #'effective-slot-definition-class class initargs)
         initargs))

(let ((stdslot (find-class 'standard-direct-slot-definition)))
  (defmethod compute-effective-slot-definition
      ((class compatible-class) slot-name direct-slots)
    "Construct an effective slot definition for the given slot."
    ;;
    ;; Ideally we don't want to mess with a slot if it's entirely handled by
    ;; the implementation.  This check seems to work OK.
    (if (every (lambda (slot)
                 (member (class-of slot)
                         (class-precedence-list stdslot)))
               direct-slots)
        (call-next-method)
        (make-effective-slot class
                             (initargs-for-effective-slot class
                                                          direct-slots)))))

;;;--------------------------------------------------------------------------
;;; Filterered slots.

(defclass filtered-slot-class-mixin (compatible-class)
  ()
  (:documentation
   "A filtered slot interposes a filter on any attempt to write to the slot.
    The filter is given the proposed new value, and should return the actual
    new value.  Specify the filter with a  `:filter SYMBOL' slot option.
    (Yes, I know that using functions would be nicer, but the MOP makes
    that surprisingly difficult.)"))

(defclass filtered-direct-slot-definition
    (standard-direct-slot-definition)
  ((filter :initarg :filter :reader slot-definition-filter)))

(defgeneric slot-definition-filter (slot)
  (:method ((slot slot-definition)) nil))

(defclass filtered-effective-slot-definition
    (standard-effective-slot-definition)
  ((filter :initarg :filter :accessor slot-definition-filter)))

(defmethod direct-slot-definition-class
    ((class filtered-slot-class-mixin)
     &key (filter nil filterp) &allow-other-keys)
  (declare (ignore filter))
  (if filterp
      (find-class 'filtered-direct-slot-definition)
      (call-next-method)))

(defmethod effective-slot-definition-class
    ((class filtered-slot-class-mixin)
     &key (filter nil filterp) &allow-other-keys)
  (declare (ignore filter))
  (if filterp
      (find-class 'filtered-effective-slot-definition)
      (call-next-method)))

(defmethod initialize-instance :after
    ((slot filtered-direct-slot-definition) &key)
  (with-slots (filter) slot
    (when (and (consp filter)
               (or (eq (car filter) 'function)
                   (eq (car filter) 'quote))
               (symbolp (cadr filter))
               (null (cddr filter)))
      (setf filter (cadr filter)))))

(defmethod initargs-for-effective-slot
    ((class filtered-slot-class-mixin) direct-slots)
  (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
    (append (and filter-slot
                 (list :filter (slot-definition-filter filter-slot)))
            (call-next-method))))

(defmethod (setf slot-value-using-class)
    (value
     (class filtered-slot-class-mixin)
     (object standard-object)
     (slot filtered-effective-slot-definition))
  (call-next-method (funcall (slot-definition-filter slot) value)
                    class object slot))

;;;--------------------------------------------------------------------------
;;; Predicates.

(defclass predicate-class-mixin (compatible-class)
  ((predicates :type list :initarg :predicate :initform nil
               :documentation "Predicate generic function to create."))
  (:documentation
   "Class which can automatically generate a predicate generic function.
    Adds the `:predicate' class option, which takes a single symbol argument
    FUNC.  If specified, and non-nil, a generic function FUNC with one
    argument will be defined (if it doesn't already exist) with a default
    method returning nil, and a method added specialized on this class
    returning a non-nil value."))

(defmethod shared-initialize :after
    ((class predicate-class-mixin) slot-names &key)
  (declare (ignore slot-names))
  (with-slots (predicates) class
    (dolist (predicate predicates)
      (let ((lambda-list '(thing)))
        (let ((gf (if (fboundp predicate)
                      (fdefinition predicate)
                      (let ((gf (ensure-generic-function
                                 predicate :lambda-list lambda-list)))
                        (add-method gf (make-instance
                                        'standard-method
                                        :specializers (list (find-class 't))
                                        :lambda-list lambda-list
                                        :function (constantly nil)))))))
          (add-method gf (make-instance 'standard-method
                                        :specializers (list class)
                                        :lambda-list lambda-list
                                        :function (constantly t))))))))

;;;--------------------------------------------------------------------------
;;; Abstract classes.

(defclass abstract-class-mixin (compatible-class)
  ()
  (:documentation
   "Confusingly enough, a concrete metaclass for abstract classes.  This
    class has a `make-instance' implementation which signals an error."))

(define-condition instantiate-abstract-class (error)
  ((class :reader instantiate-abstract-class-class :initarg :class
          :documentation "The class someone attempted to instantiate."))
  (:report (lambda (cond stream)
             (format stream "Cannot instantiate abstract class ~A."
                     (class-name (instantiate-abstract-class-class cond)))))
  (:documentation
   "Reports an attempt to instantiate an abstract class."))

(defmethod make-instance ((class abstract-class-mixin) &rest whatever)
  "Signals an error.  The caller is a naughty boy."
  (declare (ignore whatever))
  (error 'instantiate-abstract-class :class class))

;;;--------------------------------------------------------------------------
;;; Useful classes.

(defclass mdw-class (filtered-slot-class-mixin
                     predicate-class-mixin
                     compatible-class)
  ()
  (:documentation
   "A generally useful metaclass with handy features.  If I've done the
    hacking right, there shouldn't be a significant cost to using this
    metaclass for all your classes if you don't use any of its fancy
    features."))

(defclass abstract-class (mdw-class abstract-class-mixin) ())

;;;--------------------------------------------------------------------------
;;; Printing things.

(defun print-object-with-slots (obj stream)
  "Prints objects in a pleasant way.  Not too clever about circularity."
  (let ((class (pcl:class-of obj))
        (magic (cons 'magic nil)))
    (print-unreadable-object (obj stream)
      (pprint-logical-block
          (stream
           (mapcan (lambda (slot)
                     (list (or (car (slot-definition-initargs slot))
                               (slot-definition-name slot))
                           (if (slot-boundp-using-class class obj slot)
                               (slot-value-using-class class obj slot)
                               magic)))
                   (pcl:class-slots class)))
        (format stream "~S" (pcl:class-name class))
        (let ((sep nil))
          (loop
            (pprint-exit-if-list-exhausted)
            (if sep
                (format stream " ~_")
                (progn (format stream " ~@_~:I") (setf sep t)))
            (let ((name (pprint-pop))
                  (value (pprint-pop)))
              (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
                      name (eq value magic) value))))))))

;;;----- That's all, folks --------------------------------------------------