Lots of tidying up.

[lisp] / mdw-mop.lisp

;;; -*-lisp-*-
;;;
;;; 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
	#+(or cmu clisp) #:mop
	#+sbcl #:sb-mop
	#+ecl #:clos))

(in-package #:mdw.mop)

;;;--------------------------------------------------------------------------
;;; Copying instances.

(export 'copy-instance-using-class)
(defgeneric copy-instance-using-class (class object &rest initargs)
  (:documentation
   "Does the donkey-work behind copy-instance."))

(defmethod copy-instance-using-class
    ((class standard-class) object &rest initargs)
  (let ((new (apply #'allocate-instance class initargs)))
    (dolist (slot (class-slots class))
      (setf (slot-value-using-class class new slot)
	    (slot-value-using-class class object slot)))
    (apply #'shared-initialize new nil initargs)
    new))

(export 'copy-instance)
(defun copy-instance (object &rest initargs)
  "Make a copy of OBJECT, modifying it by setting slots as requested by
   INITARGS."
  (apply #'copy-instance-using-class (class-of object) object initargs))

;;;--------------------------------------------------------------------------
;;; Handy macros.

(export 'with-slot-variables)
(defmacro with-slot-variables (slots instance &body body)
  "A copy-out-and-write-back variant of with-slots.

   The SLOTS argument is a list of slot specifications, each of which has the
   form (NAME &key :update :variable).  VARIABLE defaults to NAME, and
   :update defaults to nil.

   The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
   be used in place of a singleton list.  If the CLASS is specified, then two
   good things happen: firstly the INSTANCE is declared to be a member of the
   CLASS, and secondly all the slot variables are declared to have the
   appropriate types, as dredged up from the class's effective slot
   definitions.

   The effect of all this is to return the result of evaluating BODY in an
   environment where the VARIABLEs are bound to the values of the NAMEd slots
   of the given INSTANCE.  If BODY completes successfully (rather than
   throwing out, restarting, or anything like that) then the final values of
   VARIABLEs for which UPDATE was set non-nil are written back to their
   corresponding slots.

   This stands a good chance of being rather faster than with-slots.  It
   does, however, run the risk of leaving things in an inconsistent state if
   BODY escapes half-way through.  Also, this requires recompilation if a
   class's slots change type."
  (multiple-value-bind (instance class)
      (destructuring-bind
	  (instance &key class)
	  (listify instance)
	(values instance (and class (find-class class))))
    (let ((slots (mapcar (lambda (slot)
			   (destructuring-bind
			       (name &key update (variable name))
			       (listify slot)
			     (list name variable update)))
			 (if slots
			     (listify slots)
			     (mapcar #'slot-definition-name
				     (class-slots class))))))
      (with-parsed-body (body decls) body
	(with-gensyms (instvar)
	  `(let ((,instvar ,instance))
	     ,@(and class `((declare (type ,(class-name class) ,instvar))))
	     (let ,(loop for (name var update) in slots
			 collect `(,var (slot-value ,instvar ',name)))
	       ,@(and class
		      `((declare
			 ,@(loop
			    for (name var update) in slots
			    for slot = (or (find name
						 (class-slots class)
						 :key #'slot-definition-name)
					   (error
					    "Slot ~S not found in class ~S."
					    name (class-name class)))
			    collect `(type
				      ,(slot-definition-type slot)
				      ,name)))))
	       ,@decls
	       (multiple-value-prog1
		   (progn ,@body)
		 ,@(loop for (name var update) in slots
			 when update
			 collect `(setf (slot-value ,instvar ',name)
				   ,var))))))))))

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

(export 'compatible-class)
(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.

(export 'initargs-for-effective-slot)
(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)))))

(export 'make-effective-slot)
(defun make-effective-slot (class initargs)
  "Construct an effective 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."
    (declare (ignore slot-name))
    ;;
    ;; 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.

(export 'filtered-slot-class-mixin)
(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.)"))

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

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

(export 'filtered-effective-slot-definition)
(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.

(export 'predicate-class-mixin)
(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.

(export 'abstract-class-mixin)
(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."))

(export '(instantiate-abstract-class instantiate-abstract-class-class))
(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))

;;;--------------------------------------------------------------------------
;;; Singleton classes.

(export 'singleton-class-mixin)
(defclass singleton-class-mixin (compatible-class)
  ((instance :initform nil :type (or null standard-object)))
  (:documentation
   "A class which has only one instance.  All calls to `make-instance' return
    the same object."))

(defmethod allocate-instance ((class singleton-class-mixin) &key)
  "If the class already has an instance, return it; otherwise allocate one,
   store it away, and return that."
  (with-slots (instance) class
    (or instance
	(setf instance (call-next-method)))))

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

(export 'mdw-class)
(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."))

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

(export 'singleton-class)
(defclass singleton-class (mdw-class singleton-class-mixin) ())

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

(export 'print-object-with-slots)
(defun print-object-with-slots (obj stream)
  "Prints objects in a pleasant way.  Not too clever about circularity."
  (let ((class (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)))
		   (class-slots class)))
	(format stream "~S" (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 --------------------------------------------------