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 #+cmu #:pcl)
  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     ;;
 127     ;; Ideally we don't want to mess with a slot if it's entirely handled by
 128     ;; the implementation.  This check seems to work OK.
 129     (if (every (lambda (slot)
 130                  (member (class-of slot)
 131                          (class-precedence-list stdslot)))
 132                direct-slots)
 133         (call-next-method)
 134         (make-effective-slot class
 135                              (initargs-for-effective-slot class
 136                                                           direct-slots)))))
 137
 138 ;;;--------------------------------------------------------------------------
 139 ;;; Filterered slots.
 140
 141 (defclass filtered-slot-class-mixin (compatible-class)
 142   ()
 143   (:documentation
 144    "A filtered slot interposes a filter on any attempt to write to the slot.
 145     The filter is given the proposed new value, and should return the actual
 146     new value.  Specify the filter with a  `:filter SYMBOL' slot option.
 147     (Yes, I know that using functions would be nicer, but the MOP makes
 148     that surprisingly difficult.)"))
 149
 150 (defclass filtered-direct-slot-definition
 151     (standard-direct-slot-definition)
 152   ((filter :initarg :filter :reader slot-definition-filter)))
 153
 154 (defgeneric slot-definition-filter (slot)
 155   (:method ((slot slot-definition)) nil))
 156
 157 (defclass filtered-effective-slot-definition
 158     (standard-effective-slot-definition)
 159   ((filter :initarg :filter :accessor slot-definition-filter)))
 160
 161 (defmethod direct-slot-definition-class
 162     ((class filtered-slot-class-mixin)
 163      &key (filter nil filterp) &allow-other-keys)
 164   (declare (ignore filter))
 165   (if filterp
 166       (find-class 'filtered-direct-slot-definition)
 167       (call-next-method)))
 168
 169 (defmethod effective-slot-definition-class
 170     ((class filtered-slot-class-mixin)
 171      &key (filter nil filterp) &allow-other-keys)
 172   (declare (ignore filter))
 173   (if filterp
 174       (find-class 'filtered-effective-slot-definition)
 175       (call-next-method)))
 176
 177 (defmethod initialize-instance :after
 178     ((slot filtered-direct-slot-definition) &key)
 179   (with-slots (filter) slot
 180     (when (and (consp filter)
 181                (or (eq (car filter) 'function)
 182                    (eq (car filter) 'quote))
 183                (symbolp (cadr filter))
 184                (null (cddr filter)))
 185       (setf filter (cadr filter)))))
 186
 187 (defmethod initargs-for-effective-slot
 188     ((class filtered-slot-class-mixin) direct-slots)
 189   (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
 190     (append (and filter-slot
 191                  (list :filter (slot-definition-filter filter-slot)))
 192             (call-next-method))))
 193
 194 (defmethod (setf slot-value-using-class)
 195     (value
 196      (class filtered-slot-class-mixin)
 197      (object standard-object)
 198      (slot filtered-effective-slot-definition))
 199   (call-next-method (funcall (slot-definition-filter slot) value)
 200                     class object slot))
 201
 202 ;;;--------------------------------------------------------------------------
 203 ;;; Predicates.
 204
 205 (defclass predicate-class-mixin (compatible-class)
 206   ((predicates :type list :initarg :predicate :initform nil
 207                :documentation "Predicate generic function to create."))
 208   (:documentation
 209    "Class which can automatically generate a predicate generic function.
 210     Adds the `:predicate' class option, which takes a single symbol argument
 211     FUNC.  If specified, and non-nil, a generic function FUNC with one
 212     argument will be defined (if it doesn't already exist) with a default
 213     method returning nil, and a method added specialized on this class
 214     returning a non-nil value."))
 215
 216 (defmethod shared-initialize :after
 217     ((class predicate-class-mixin) slot-names &key)
 218   (declare (ignore slot-names))
 219   (with-slots (predicates) class
 220     (dolist (predicate predicates)
 221       (let ((lambda-list '(thing)))
 222         (let ((gf (if (fboundp predicate)
 223                       (fdefinition predicate)
 224                       (let ((gf (ensure-generic-function
 225                                  predicate :lambda-list lambda-list)))
 226                         (add-method gf (make-instance
 227                                         'standard-method
 228                                         :specializers (list (find-class 't))
 229                                         :lambda-list lambda-list
 230                                         :function (constantly nil)))))))
 231           (add-method gf (make-instance 'standard-method
 232                                         :specializers (list class)
 233                                         :lambda-list lambda-list
 234                                         :function (constantly t))))))))
 235
 236 ;;;--------------------------------------------------------------------------
 237 ;;; Abstract classes.
 238
 239 (defclass abstract-class-mixin (compatible-class)
 240   ()
 241   (:documentation
 242    "Confusingly enough, a concrete metaclass for abstract classes.  This
 243     class has a `make-instance' implementation which signals an error."))
 244
 245 (define-condition instantiate-abstract-class (error)
 246   ((class :reader instantiate-abstract-class-class :initarg :class
 247           :documentation "The class someone attempted to instantiate."))
 248   (:report (lambda (cond stream)
 249              (format stream "Cannot instantiate abstract class ~A."
 250                      (class-name (instantiate-abstract-class-class cond)))))
 251   (:documentation
 252    "Reports an attempt to instantiate an abstract class."))
 253
 254 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
 255   "Signals an error.  The caller is a naughty boy."
 256   (declare (ignore whatever))
 257   (error 'instantiate-abstract-class :class class))
 258
 259 ;;;--------------------------------------------------------------------------
 260 ;;; Singleton classes.
 261
 262 (defclass singleton-class-mixin (compatible-class)
 263   ((instance :initform nil :type (or null standard-object)))
 264   (:documentation
 265    "A class which has only one instance.  All calls to `make-instance' return
 266     the same object."))
 267
 268 (defmethod allocate-instance ((class singleton-class-mixin) &key)
 269   "If the class already has an instance, return it; otherwise allocate one,
 270    store it away, and return that."
 271   (with-slots (instance) class
 272     (or instance
 273         (setf instance (call-next-method)))))
 274
 275 ;;;--------------------------------------------------------------------------
 276 ;;; Useful classes.
 277
 278 (defclass mdw-class (filtered-slot-class-mixin
 279                      predicate-class-mixin
 280                      compatible-class)
 281   ()
 282   (:documentation
 283    "A generally useful metaclass with handy features.  If I've done the
 284     hacking right, there shouldn't be a significant cost to using this
 285     metaclass for all your classes if you don't use any of its fancy
 286     features."))
 287
 288 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 289 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 290
 291 ;;;--------------------------------------------------------------------------
 292 ;;; Printing things.
 293
 294 (defun print-object-with-slots (obj stream)
 295   "Prints objects in a pleasant way.  Not too clever about circularity."
 296   (let ((class (pcl:class-of obj))
 297         (magic (cons 'magic nil)))
 298     (print-unreadable-object (obj stream)
 299       (pprint-logical-block
 300           (stream
 301            (mapcan (lambda (slot)
 302                      (list (or (car (slot-definition-initargs slot))
 303                                (slot-definition-name slot))
 304                            (if (slot-boundp-using-class class obj slot)
 305                                (slot-value-using-class class obj slot)
 306                                magic)))
 307                    (pcl:class-slots class)))
 308         (format stream "~S" (pcl:class-name class))
 309         (let ((sep nil))
 310           (loop
 311             (pprint-exit-if-list-exhausted)
 312             (if sep
 313                 (format stream " ~_")
 314                 (progn (format stream " ~@_~:I") (setf sep t)))
 315             (let ((name (pprint-pop))
 316                   (value (pprint-pop)))
 317               (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
 318                       name (eq value magic) value))))))))
 319
 320 ;;;----- That's all, folks --------------------------------------------------