mop: Don't pass filter functions the target object.

[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 #+cmu #:pcl)
  (:export #:compatible-class
	   #:initargs-for-effective-slot #:make-effective-slot
	   #:filtered-slot-class-mixin
	     #:filtered-direct-slot-definition
	     #:filtered-effective-slot-definition
	   #: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 &allow-other-keys)
  (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))

;;;--------------------------------------------------------------------------
;;; 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
		     compatible-class)
  ())

(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 ~@_~:[~S~;<unbound>~*~]"
                      name (eq value magic) value))))))))

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