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
  31         #+(or cmu clisp) #:mop
  32         #+sbcl #:sb-mop
  33         #+ecl #:clos)
  34   (:export #:copy-instance #:copy-instance-using-class
  35            #:with-slot-variables
  36            #:compatible-class
  37            #:initargs-for-effective-slot #:make-effective-slot
  38            #:filtered-slot-class-mixin
  39              #:filtered-direct-slot-definition
  40              #:filtered-effective-slot-definition
  41            #:predicate-class-mixin
  42            #:abstract-class-mixin #:instantiate-abstract-class
  43            #:singleton-class-mixin
  44            #:mdw-class #:abstract-class #:singleton-class
  45            #:print-object-with-slots))
  46
  47 (in-package #:mdw.mop)
  48
  49 ;;;--------------------------------------------------------------------------
  50 ;;; Copying instances.
  51
  52 (defgeneric copy-instance-using-class (class object &rest initargs)
  53   (:documentation
  54    "Does the donkey-work behind copy-instance."))
  55
  56 (defmethod copy-instance-using-class
  57     ((class standard-class) object &rest initargs)
  58   (let ((new (apply #'allocate-instance class initargs)))
  59     (dolist (slot (class-slots class))
  60       (setf (slot-value-using-class class new slot)
  61             (slot-value-using-class class object slot)))
  62     (apply #'shared-initialize new nil initargs)
  63     new))
  64
  65 (defun copy-instance (object &rest initargs)
  66   "Make a copy of OBJECT, modifying it by setting slots as requested by
  67    INITARGS."
  68   (apply #'copy-instance-using-class (class-of object) object initargs))
  69
  70 ;;;--------------------------------------------------------------------------
  71 ;;; Handy macros.
  72
  73 (defmacro with-slot-variables (slots instance &body body)
  74   "A copy-out-and-write-back variant of with-slots.
  75
  76    The SLOTS argument is a list of slot specifications, each of which has the
  77    form (NAME &key :update :variable).  VARIABLE defaults to NAME, and
  78    :update defaults to nil.
  79
  80    The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
  81    be used in place of a singleton list.  If the CLASS is specified, then two
  82    good things happen: firstly the INSTANCE is declared to be a member of the
  83    CLASS, and secondly all the slot variables are declared to have the
  84    appropriate types, as dredged up from the class's effective slot
  85    definitions.
  86
  87    The effect of all this is to return the result of evaluating BODY in an
  88    environment where the VARIABLEs are bound to the values of the NAMEd slots
  89    of the given INSTANCE.  If BODY completes successfully (rather than
  90    throwing out, restarting, or anything like that) then the final values of
  91    VARIABLEs for which UPDATE was set non-nil are written back to their
  92    corresponding slots.
  93
  94    This stands a good chance of being rather faster than with-slots.  It
  95    does, however, run the risk of leaving things in an inconsistent state if
  96    BODY escapes half-way through.  Also, this requires recompilation if a
  97    class's slots change type."
  98   (multiple-value-bind (instance class)
  99       (destructuring-bind
 100           (instance &key class)
 101           (listify instance)
 102         (values instance (and class (find-class class))))
 103     (let ((slots (mapcar (lambda (slot)
 104                            (destructuring-bind
 105                                (name &key update (variable name))
 106                                (listify slot)
 107                              (list name variable update)))
 108                          (if slots
 109                              (listify slots)
 110                              (mapcar #'slot-definition-name
 111                                      (class-slots class))))))
 112       (with-parsed-body (body decls) body
 113         (with-gensyms (instvar)
 114           `(let ((,instvar ,instance))
 115              ,@(and class `((declare (type ,(class-name class) ,instvar))))
 116              (let ,(loop for (name var update) in slots
 117                          collect `(,var (slot-value ,instvar ',name)))
 118                ,@(and class
 119                       `((declare
 120                          ,@(loop
 121                             for (name var update) in slots
 122                             for slot = (or (find name
 123                                                  (class-slots class)
 124                                                  :key #'slot-definition-name)
 125                                            (error
 126                                             "Slot ~S not found in class ~S."
 127                                             name (class-name class)))
 128                             collect `(type
 129                                       ,(slot-definition-type slot)
 130                                       ,name)))))
 131                ,@decls
 132                (multiple-value-prog1
 133                    (progn ,@body)
 134                  ,@(loop for (name var update) in slots
 135                          when update
 136                          collect `(setf (slot-value ,instvar ',name)
 137                                    ,var))))))))))
 138
 139 ;;;--------------------------------------------------------------------------
 140 ;;; Basic stuff.
 141
 142 (defclass compatible-class (standard-class)
 143   ()
 144   (:documentation
 145    "A class which can be be freely used in class heirarchies with
 146     standard-class and other subclasses of compatible-class.  This saves a
 147     bunch of annoying messing about with `validate-superclass'."))
 148
 149 (defmethod validate-superclass
 150     ((sub compatible-class) (super compatible-class))
 151   t)
 152
 153 (defmethod validate-superclass
 154     ((sub compatible-class) (super standard-class))
 155   (eq (class-of super) (find-class 'standard-class)))
 156
 157 (defmethod validate-superclass
 158     ((sub standard-class) (super compatible-class))
 159   (eq (class-of sub) (find-class 'standard-class)))
 160
 161 ;;;--------------------------------------------------------------------------
 162 ;;; Utilities for messing with slot options.
 163
 164 (defgeneric initargs-for-effective-slot (class direct-slots)
 165   (:documentation
 166    "Missing functionality from the MOP: given a class and its direct slots
 167     definitions, construct and return the proposed initializer list for
 168     constructing the effective-slot."))
 169
 170 (defmethod initargs-for-effective-slot
 171     ((class standard-class) direct-slots)
 172   "Extract the effective slot options as required."
 173   ;;
 174   ;; This is taken from the Closette implementation, but it seems to work!
 175   (let ((init-slot (find-if-not #'null direct-slots
 176                                 :key #'slot-definition-initfunction)))
 177     (list :name (slot-definition-name (car direct-slots))
 178           :initform (and init-slot
 179                          (slot-definition-initform init-slot))
 180           :initfunction (and init-slot
 181                              (slot-definition-initfunction init-slot))
 182           :initargs (remove-duplicates
 183                      (apply #'append
 184                             (mapcar #'slot-definition-initargs
 185                                     direct-slots)))
 186           :allocation (slot-definition-allocation (car direct-slots)))))
 187
 188 (defun make-effective-slot (class initargs)
 189   "Construct an effectie slot definition for a slot on the class, given the
 190    required arguments."
 191   (apply #'make-instance
 192          (apply #'effective-slot-definition-class class initargs)
 193          initargs))
 194
 195 (let ((stdslot (find-class 'standard-direct-slot-definition)))
 196   (defmethod compute-effective-slot-definition
 197       ((class compatible-class) slot-name direct-slots)
 198     "Construct an effective slot definition for the given slot."
 199     (declare (ignore slot-name))
 200     ;;
 201     ;; Ideally we don't want to mess with a slot if it's entirely handled by
 202     ;; the implementation.  This check seems to work OK.
 203     (if (every (lambda (slot)
 204                  (member (class-of slot)
 205                          (class-precedence-list stdslot)))
 206                direct-slots)
 207         (call-next-method)
 208         (make-effective-slot class
 209                              (initargs-for-effective-slot class
 210                                                           direct-slots)))))
 211
 212 ;;;--------------------------------------------------------------------------
 213 ;;; Filterered slots.
 214
 215 (defclass filtered-slot-class-mixin (compatible-class)
 216   ()
 217   (:documentation
 218    "A filtered slot interposes a filter on any attempt to write to the slot.
 219     The filter is given the proposed new value, and should return the actual
 220     new value.  Specify the filter with a  `:filter SYMBOL' slot option.
 221     (Yes, I know that using functions would be nicer, but the MOP makes
 222     that surprisingly difficult.)"))
 223
 224 (defgeneric slot-definition-filter (slot)
 225   (:method ((slot slot-definition)) nil))
 226
 227 (defclass filtered-direct-slot-definition
 228     (standard-direct-slot-definition)
 229   ((filter :initarg :filter :reader slot-definition-filter)))
 230
 231 (defclass filtered-effective-slot-definition
 232     (standard-effective-slot-definition)
 233   ((filter :initarg :filter :accessor slot-definition-filter)))
 234
 235 (defmethod direct-slot-definition-class
 236     ((class filtered-slot-class-mixin)
 237      &key (filter nil filterp) &allow-other-keys)
 238   (declare (ignore filter))
 239   (if filterp
 240       (find-class 'filtered-direct-slot-definition)
 241       (call-next-method)))
 242
 243 (defmethod effective-slot-definition-class
 244     ((class filtered-slot-class-mixin)
 245      &key (filter nil filterp) &allow-other-keys)
 246   (declare (ignore filter))
 247   (if filterp
 248       (find-class 'filtered-effective-slot-definition)
 249       (call-next-method)))
 250
 251 (defmethod initialize-instance :after
 252     ((slot filtered-direct-slot-definition) &key)
 253   (with-slots (filter) slot
 254     (when (and (consp filter)
 255                (or (eq (car filter) 'function)
 256                    (eq (car filter) 'quote))
 257                (symbolp (cadr filter))
 258                (null (cddr filter)))
 259       (setf filter (cadr filter)))))
 260
 261 (defmethod initargs-for-effective-slot
 262     ((class filtered-slot-class-mixin) direct-slots)
 263   (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
 264     (append (and filter-slot
 265                  (list :filter (slot-definition-filter filter-slot)))
 266             (call-next-method))))
 267
 268 (defmethod (setf slot-value-using-class)
 269     (value
 270      (class filtered-slot-class-mixin)
 271      (object standard-object)
 272      (slot filtered-effective-slot-definition))
 273   (call-next-method (funcall (slot-definition-filter slot) value)
 274                     class object slot))
 275
 276 ;;;--------------------------------------------------------------------------
 277 ;;; Predicates.
 278
 279 (defclass predicate-class-mixin (compatible-class)
 280   ((predicates :type list :initarg :predicate :initform nil
 281                :documentation "Predicate generic function to create."))
 282   (:documentation
 283    "Class which can automatically generate a predicate generic function.
 284     Adds the `:predicate' class option, which takes a single symbol argument
 285     FUNC.  If specified, and non-nil, a generic function FUNC with one
 286     argument will be defined (if it doesn't already exist) with a default
 287     method returning nil, and a method added specialized on this class
 288     returning a non-nil value."))
 289
 290 (defmethod shared-initialize :after
 291     ((class predicate-class-mixin) slot-names &key)
 292   (declare (ignore slot-names))
 293   (with-slots (predicates) class
 294     (dolist (predicate predicates)
 295       (let ((lambda-list '(thing)))
 296         (let ((gf (if (fboundp predicate)
 297                       (fdefinition predicate)
 298                       (let ((gf (ensure-generic-function
 299                                  predicate :lambda-list lambda-list)))
 300                         (add-method gf (make-instance
 301                                         'standard-method
 302                                         :specializers (list (find-class 't))
 303                                         :lambda-list lambda-list
 304                                         :function (constantly nil)))))))
 305           (add-method gf (make-instance 'standard-method
 306                                         :specializers (list class)
 307                                         :lambda-list lambda-list
 308                                         :function (constantly t))))))))
 309
 310 ;;;--------------------------------------------------------------------------
 311 ;;; Abstract classes.
 312
 313 (defclass abstract-class-mixin (compatible-class)
 314   ()
 315   (:documentation
 316    "Confusingly enough, a concrete metaclass for abstract classes.  This
 317     class has a `make-instance' implementation which signals an error."))
 318
 319 (define-condition instantiate-abstract-class (error)
 320   ((class :reader instantiate-abstract-class-class :initarg :class
 321           :documentation "The class someone attempted to instantiate."))
 322   (:report (lambda (cond stream)
 323              (format stream "Cannot instantiate abstract class ~A."
 324                      (class-name (instantiate-abstract-class-class cond)))))
 325   (:documentation
 326    "Reports an attempt to instantiate an abstract class."))
 327
 328 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
 329   "Signals an error.  The caller is a naughty boy."
 330   (declare (ignore whatever))
 331   (error 'instantiate-abstract-class :class class))
 332
 333 ;;;--------------------------------------------------------------------------
 334 ;;; Singleton classes.
 335
 336 (defclass singleton-class-mixin (compatible-class)
 337   ((instance :initform nil :type (or null standard-object)))
 338   (:documentation
 339    "A class which has only one instance.  All calls to `make-instance' return
 340     the same object."))
 341
 342 (defmethod allocate-instance ((class singleton-class-mixin) &key)
 343   "If the class already has an instance, return it; otherwise allocate one,
 344    store it away, and return that."
 345   (with-slots (instance) class
 346     (or instance
 347         (setf instance (call-next-method)))))
 348
 349 ;;;--------------------------------------------------------------------------
 350 ;;; Useful classes.
 351
 352 (defclass mdw-class (filtered-slot-class-mixin
 353                      predicate-class-mixin
 354                      compatible-class)
 355   ()
 356   (:documentation
 357    "A generally useful metaclass with handy features.  If I've done the
 358     hacking right, there shouldn't be a significant cost to using this
 359     metaclass for all your classes if you don't use any of its fancy
 360     features."))
 361
 362 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 363 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 364
 365 ;;;--------------------------------------------------------------------------
 366 ;;; Printing things.
 367
 368 (defun print-object-with-slots (obj stream)
 369   "Prints objects in a pleasant way.  Not too clever about circularity."
 370   (let ((class (class-of obj))
 371         (magic (cons 'magic nil)))
 372     (print-unreadable-object (obj stream)
 373       (pprint-logical-block
 374           (stream
 375            (mapcan (lambda (slot)
 376                      (list (or (car (slot-definition-initargs slot))
 377                                (slot-definition-name slot))
 378                            (if (slot-boundp-using-class class obj slot)
 379                                (slot-value-using-class class obj slot)
 380                                magic)))
 381                    (class-slots class)))
 382         (format stream "~S" (class-name class))
 383         (let ((sep nil))
 384           (loop
 385             (pprint-exit-if-list-exhausted)
 386             (if sep
 387                 (format stream " ~_")
 388                 (progn (format stream " ~@_~:I") (setf sep t)))
 389             (let ((name (pprint-pop))
 390                   (value (pprint-pop)))
 391               (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
 392                       name (eq value magic) value))))))))
 393
 394 ;;;----- That's all, folks --------------------------------------------------