mdw@git.distorted.org.uk Git - lisp/blob - mdw-mop.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Useful bits of MOP hacking
   6 ;;;
   7 ;;; (c) 2006 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Packages.
  28
  29 (defpackage #:mdw.mop
  30   (:use #:common-lisp #:mdw.base #+(or cmu clisp) #:mop)
  31   (:export #:compatible-class
  32            #:copy-instance #:copy-instance-using-class
  33            #:initargs-for-effective-slot #:make-effective-slot
  34            #:filtered-slot-class-mixin
  35              #:filtered-direct-slot-definition
  36              #:filtered-effective-slot-definition
  37            #:predicate-class-mixin
  38            #:abstract-class-mixin #:instantiate-abstract-class
  39            #:singleton-class-mixin
  40            #:mdw-class #:abstract-class #:singleton-class
  41            #:print-object-with-slots))
  42
  43 (in-package #:mdw.mop)
  44
  45 ;;;--------------------------------------------------------------------------
  46 ;;; Basic stuff.
  47
  48 (defclass compatible-class (standard-class)
  49   ()
  50   (:documentation
  51    "A class which can be be freely used in class heirarchies with
  52     standard-class and other subclasses of compatible-class.  This saves a
  53     bunch of annoying messing about with `validate-superclass'."))
  54
  55 (defmethod validate-superclass
  56     ((sub compatible-class) (super compatible-class))
  57   t)
  58
  59 (defmethod validate-superclass
  60     ((sub compatible-class) (super standard-class))
  61   (eq (class-of super) (find-class 'standard-class)))
  62
  63 (defmethod validate-superclass
  64     ((sub standard-class) (super compatible-class))
  65   (eq (class-of sub) (find-class 'standard-class)))
  66
  67 ;;;--------------------------------------------------------------------------
  68 ;;; Copying instances.
  69
  70 (defgeneric copy-instance-using-class (class object &rest initargs)
  71   (:documentation
  72    "Does the donkey-work behind copy-instance."))
  73
  74 (defmethod copy-instance-using-class
  75     ((class standard-class) object &rest initargs)
  76   (let ((new (apply #'allocate-instance class initargs)))
  77     (dolist (slot (class-slots class))
  78       (setf (slot-value-using-class class new slot)
  79             (slot-value-using-class class object slot)))
  80     (apply #'shared-initialize new nil initargs)
  81     new))
  82
  83 (defun copy-instance (object &rest initargs)
  84   "Make a copy of OBJECT, modifying it by setting slots as requested by
  85    INITARGS."
  86   (apply #'copy-instance-using-class (class-of object) object initargs))
  87
  88 ;;;--------------------------------------------------------------------------
  89 ;;; Utilities for messing with slot options.
  90
  91 (defgeneric initargs-for-effective-slot (class direct-slots)
  92   (:documentation
  93    "Missing functionality from the MOP: given a class and its direct slots
  94     definitions, construct and return the proposed initializer list for
  95     constructing the effective-slot."))
  96
  97 (defmethod initargs-for-effective-slot
  98     ((class standard-class) direct-slots)
  99   "Extract the effective slot options as required."
 100   ;;
 101   ;; This is taken from the Closette implementation, but it seems to work!
 102   (let ((init-slot (find-if-not #'null direct-slots
 103                                 :key #'slot-definition-initfunction)))
 104     (list :name (slot-definition-name (car direct-slots))
 105           :initform (and init-slot
 106                          (slot-definition-initform init-slot))
 107           :initfunction (and init-slot
 108                              (slot-definition-initfunction init-slot))
 109           :initargs (remove-duplicates
 110                      (apply #'append
 111                             (mapcar #'slot-definition-initargs
 112                                     direct-slots)))
 113           :allocation (slot-definition-allocation (car direct-slots)))))
 114
 115 (defun make-effective-slot (class initargs)
 116   "Construct an effectie slot definition for a slot on the class, given the
 117    required arguments."
 118   (apply #'make-instance
 119          (apply #'effective-slot-definition-class class initargs)
 120          initargs))
 121
 122 (let ((stdslot (find-class 'standard-direct-slot-definition)))
 123   (defmethod compute-effective-slot-definition
 124       ((class compatible-class) slot-name direct-slots)
 125     "Construct an effective slot definition for the given slot."
 126     (declare (ignore slot-name))
 127     ;;
 128     ;; Ideally we don't want to mess with a slot if it's entirely handled by
 129     ;; the implementation.  This check seems to work OK.
 130     (if (every (lambda (slot)
 131                  (member (class-of slot)
 132                          (class-precedence-list stdslot)))
 133                direct-slots)
 134         (call-next-method)
 135         (make-effective-slot class
 136                              (initargs-for-effective-slot class
 137                                                           direct-slots)))))
 138
 139 ;;;--------------------------------------------------------------------------
 140 ;;; Filterered slots.
 141
 142 (defclass filtered-slot-class-mixin (compatible-class)
 143   ()
 144   (:documentation
 145    "A filtered slot interposes a filter on any attempt to write to the slot.
 146     The filter is given the proposed new value, and should return the actual
 147     new value.  Specify the filter with a  `:filter SYMBOL' slot option.
 148     (Yes, I know that using functions would be nicer, but the MOP makes
 149     that surprisingly difficult.)"))
 150
 151 (defclass filtered-direct-slot-definition
 152     (standard-direct-slot-definition)
 153   ((filter :initarg :filter :reader slot-definition-filter)))
 154
 155 (defgeneric slot-definition-filter (slot)
 156   (:method ((slot slot-definition)) nil))
 157
 158 (defclass filtered-effective-slot-definition
 159     (standard-effective-slot-definition)
 160   ((filter :initarg :filter :accessor slot-definition-filter)))
 161
 162 (defmethod direct-slot-definition-class
 163     ((class filtered-slot-class-mixin)
 164      &key (filter nil filterp) &allow-other-keys)
 165   (declare (ignore filter))
 166   (if filterp
 167       (find-class 'filtered-direct-slot-definition)
 168       (call-next-method)))
 169
 170 (defmethod effective-slot-definition-class
 171     ((class filtered-slot-class-mixin)
 172      &key (filter nil filterp) &allow-other-keys)
 173   (declare (ignore filter))
 174   (if filterp
 175       (find-class 'filtered-effective-slot-definition)
 176       (call-next-method)))
 177
 178 (defmethod initialize-instance :after
 179     ((slot filtered-direct-slot-definition) &key)
 180   (with-slots (filter) slot
 181     (when (and (consp filter)
 182                (or (eq (car filter) 'function)
 183                    (eq (car filter) 'quote))
 184                (symbolp (cadr filter))
 185                (null (cddr filter)))
 186       (setf filter (cadr filter)))))
 187
 188 (defmethod initargs-for-effective-slot
 189     ((class filtered-slot-class-mixin) direct-slots)
 190   (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
 191     (append (and filter-slot
 192                  (list :filter (slot-definition-filter filter-slot)))
 193             (call-next-method))))
 194
 195 (defmethod (setf slot-value-using-class)
 196     (value
 197      (class filtered-slot-class-mixin)
 198      (object standard-object)
 199      (slot filtered-effective-slot-definition))
 200   (call-next-method (funcall (slot-definition-filter slot) value)
 201                     class object slot))
 202
 203 ;;;--------------------------------------------------------------------------
 204 ;;; Predicates.
 205
 206 (defclass predicate-class-mixin (compatible-class)
 207   ((predicates :type list :initarg :predicate :initform nil
 208                :documentation "Predicate generic function to create."))
 209   (:documentation
 210    "Class which can automatically generate a predicate generic function.
 211     Adds the `:predicate' class option, which takes a single symbol argument
 212     FUNC.  If specified, and non-nil, a generic function FUNC with one
 213     argument will be defined (if it doesn't already exist) with a default
 214     method returning nil, and a method added specialized on this class
 215     returning a non-nil value."))
 216
 217 (defmethod shared-initialize :after
 218     ((class predicate-class-mixin) slot-names &key)
 219   (declare (ignore slot-names))
 220   (with-slots (predicates) class
 221     (dolist (predicate predicates)
 222       (let ((lambda-list '(thing)))
 223         (let ((gf (if (fboundp predicate)
 224                       (fdefinition predicate)
 225                       (let ((gf (ensure-generic-function
 226                                  predicate :lambda-list lambda-list)))
 227                         (add-method gf (make-instance
 228                                         'standard-method
 229                                         :specializers (list (find-class 't))
 230                                         :lambda-list lambda-list
 231                                         :function (constantly nil)))))))
 232           (add-method gf (make-instance 'standard-method
 233                                         :specializers (list class)
 234                                         :lambda-list lambda-list
 235                                         :function (constantly t))))))))
 236
 237 ;;;--------------------------------------------------------------------------
 238 ;;; Abstract classes.
 239
 240 (defclass abstract-class-mixin (compatible-class)
 241   ()
 242   (:documentation
 243    "Confusingly enough, a concrete metaclass for abstract classes.  This
 244     class has a `make-instance' implementation which signals an error."))
 245
 246 (define-condition instantiate-abstract-class (error)
 247   ((class :reader instantiate-abstract-class-class :initarg :class
 248           :documentation "The class someone attempted to instantiate."))
 249   (:report (lambda (cond stream)
 250              (format stream "Cannot instantiate abstract class ~A."
 251                      (class-name (instantiate-abstract-class-class cond)))))
 252   (:documentation
 253    "Reports an attempt to instantiate an abstract class."))
 254
 255 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
 256   "Signals an error.  The caller is a naughty boy."
 257   (declare (ignore whatever))
 258   (error 'instantiate-abstract-class :class class))
 259
 260 ;;;--------------------------------------------------------------------------
 261 ;;; Singleton classes.
 262
 263 (defclass singleton-class-mixin (compatible-class)
 264   ((instance :initform nil :type (or null standard-object)))
 265   (:documentation
 266    "A class which has only one instance.  All calls to `make-instance' return
 267     the same object."))
 268
 269 (defmethod allocate-instance ((class singleton-class-mixin) &key)
 270   "If the class already has an instance, return it; otherwise allocate one,
 271    store it away, and return that."
 272   (with-slots (instance) class
 273     (or instance
 274         (setf instance (call-next-method)))))
 275
 276 ;;;--------------------------------------------------------------------------
 277 ;;; Useful classes.
 278
 279 (defclass mdw-class (filtered-slot-class-mixin
 280                      predicate-class-mixin
 281                      compatible-class)
 282   ()
 283   (:documentation
 284    "A generally useful metaclass with handy features.  If I've done the
 285     hacking right, there shouldn't be a significant cost to using this
 286     metaclass for all your classes if you don't use any of its fancy
 287     features."))
 288
 289 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 290 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 291
 292 ;;;--------------------------------------------------------------------------
 293 ;;; Printing things.
 294
 295 (defun print-object-with-slots (obj stream)
 296   "Prints objects in a pleasant way.  Not too clever about circularity."
 297   (let ((class (class-of obj))
 298         (magic (cons 'magic nil)))
 299     (print-unreadable-object (obj stream)
 300       (pprint-logical-block
 301           (stream
 302            (mapcan (lambda (slot)
 303                      (list (or (car (slot-definition-initargs slot))
 304                                (slot-definition-name slot))
 305                            (if (slot-boundp-using-class class obj slot)
 306                                (slot-value-using-class class obj slot)
 307                                magic)))
 308                    (class-slots class)))
 309         (format stream "~S" (class-name class))
 310         (let ((sep nil))
 311           (loop
 312             (pprint-exit-if-list-exhausted)
 313             (if sep
 314                 (format stream " ~_")
 315                 (progn (format stream " ~@_~:I") (setf sep t)))
 316             (let ((name (pprint-pop))
 317                   (value (pprint-pop)))
 318               (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
 319                       name (eq value magic) value))))))))
 320
 321 ;;;----- That's all, folks --------------------------------------------------