Playing the Slots with MOP

⃪ series back --- CLOS Encounters --- series forward →

Learning About Slot Metaobjects

In which the Metaobject Protocol is leveraged to customize behavior of slot access for CLOS objects, which opens up possibilities for a few design patterns, such as Observer and Momento. Such patterns merely scratch the surface, however, and subsequent posts may dig into the technique more deeply.

The Desired Effect

Suppose you need to execute some code whenever an object is modified. To achieve this, you must have two things:

A way to monitor changes to your class instances and
A way to specify which code is called on which instances.

The second one is pretty easy - just use a bog standard generic function:

     ;; specialized on classes with metaclass = monitored-class  
     (defgeneric on-slot-set (object slot-name old-value new-value)  
       (:documentation "called whenever a monitored slot is modified."))

The first part, monitoring changes to class instances, is trickier, and is the main topic of this post.

In this post you will be working with a metaclass called monitored-class. Monitored classes will allow you to specify that you'd like some slots of your class to be monitored, which will call on-slot-set whenever their values change.

If you've read the two previous posts in this series, you're already accustomed to defining metaclasses. If not, it's pretty painless: you define a subclass of standard-class, then you tell CLOS that you know what you're doing:

     ;; subclass of standard-class  
     (defclass monitored-class (standard-class) ())  
      
     ;; yup, you know what you're doing  
     (defmethod closer-mop:validate-superclass  
         ((sub monitored-class) (sup standard-class))  
       t)

Just to give you an example of the kind of thing you might want to do, here is a dummy class that might use monitored slots:

     ;; example monitored class  
     (defclass person ()  
       ((name :reader person-name  
              :initarg :name  
              :initform (error "People have names."))  
        (age :accessor person-age  
             :initarg :age  
             :initform 0  
             :monitored t)          ; celebrate birthdays?  
        (job :accessor person-job  
             :initarg :job  
             :initform "unemployed"  
             :monitored t))         ; congratulations?  
       (:metaclass monitored-class))  
      
     ;; general logging of monitored slot changes  
     (defmethod on-slot-set ((person person) slot old new)  
        (print (list :altering person :slot slot :from old :to new)))  
      
     ;; in the case of a birthday, celebrate it  
     (defmethod on-slot-set :after  
         ((person person) (name  (eql 'age)) old  new)  
       (when (and old (= (1+ old) new))  
           (print "Happy Birthday!")))  
      
     ;; if a person gets a new job, congratulate them  
     (defmethod on-slot-set :after  
         ((person person) (name (eql 'job)) old new)  
       (unless (or (not (stringp new)) (string-equal new "unemployed"))  
         (print "Congratulations on the new job!")))

Just a quick example using the above:

     > ;; instantiate PERSON and have a birthday  
     > (make-instance 'person :name "Buckaroo Banzai"  
                              :age 35  
                              :job "Rock n' Roller")  
     > (incf (person-age *))  
     (:altering #<PERSON {1002C393D3}> :slot age :old 35 :new 36)  
     Happy Birthday!  
     36

Now, time to see how its done!

The Magniloquent Verbosity of the Metaobject Protocol

In order to achieve the desired effect, you will be specializing a few MOP generic functions that deal with slots. These functions, you should be warned, have somewhat long and obnoxiously similar sounding names. The pertinent functions, and an explanation of what you use them for, are as follows

`direct-slot-definition-class`

You will recall that whenever you define a class with defclass you can specify slot options like :initform and :initarg and so on. These options are used by CLOS to initialize an instance of standard-direct-slot-definition. If you want to add more options to your class definitions, you need to make a subclass of standard-direct-slot-definition and put them in there. Then, in order to tell CLOS about your custom slot definition subclass, the direct-slot-definition-class method must be specialized for your metaclass.

Concretely:

     ;; subclass of standard-direct-slot-definition  
     (defclass monitored-direct-slot-definition  
         (closer-mop:standard-direct-slot-definition)  
       ((monitored  
         :initarg :monitored  
         :initform nil  
         :documentation "A slot option indicating that the  
                        slot is to be monitored.")))  
      
     ;; letting CLOS know that you want to use your custom  
     ;; class whenever :monitored is non null  
     ;; otherwise, you'll just use the standard slot definition class.  
     (defmethod closer-mop:direct-slot-definition-class  
         ((class monitored-class) &key monitored &allow-other-keys)  
       (if monitored  
           'monitored-direct-slot-definition  
           (call-next-method)))

The direct-slot-definition-class is specialzied on monitored-class. The rest of the arguments it receives are, for the most part, the slot options you include in your defclass forms.

`effective-slot-definition-class`

If you can, I'd like you to open up a REPL, load closer-mop from quicklisp and define a class, any class. Or, if you're feeling lazy, just copy and paste:

     ;; load closer-mop  
     (ql:quickload :closer-mop)  
     (defclass moo () (a b c))  
     (closer-mop:ensure-finalized (find-class 'moo))

Now I want you call class-slots on your new class

     (closer-mop:class-slots (find-class 'moo))

If you run the above, you should see a list that looks something like:

     ; slots  
     (#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION COMMON-LISP-USER::A>  
      #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION COMMON-LISP-USER::B>  
      #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION COMMON-LISP-USER::C>)

The main thing I want you to take away is that the slots you end up with in your class are all instances of standard-effective-slot-definition.

Effective slot definitions are what actually ends up in a class, and they are computed using direct slot definitions as input. The reason I say computed from direct slot definitions, plural, is that a class might have several superclasses, and each might define the same slot with slightly differing options.

You will be computing effective slots yourself in a moment, but for now you need to extend standard-effective-slot-definition.

So, just like in the above case with the direct slot definition class, you need to indicate that you want your slots to be :monitored, and you must also tell CLOS that monitored-class will use your custom effective slots:

     ;; a custom effective slot definition class  
     (defclass monitored-effective-slot-definition  
         (closer-mop:standard-effective-slot-definition)  
       ((monitored :initarg :monitored  :initform nil)))  
      
     ;; let clos know what you're doing  
     (defmethod closer-mop:effective-slot-definition-class  
         ((class monitored-class) &rest initargs)  
       'monitored-effective-slot-definition )

`compute-effective-slot-definition`

As promised, you will now be turning your monitored-direct-slot-definition instances into monitored-effective-slot-definition instances. During class construction, the metaobject protocol determines which effective slots end up in your classes by calling compute-effective-slot-definition. It is this method that you can specialize like so:

     ;; specialize on monitored-class  
     (defmethod closer-mop:compute-effective-slot-definition  
         ((class monitored-class) name direct-slots)  
       (let ((effective-slot (call-next-method)))  
         (when (some (lambda (ds) (typep ds 'monitored-direct-slot-definition))  
                     direct-slots)  
           (setf (slot-value effective-slot 'monitored) t))  
         effective-slot))

Here is how it all works:

First, the normal effective slot is computed via call-next-method. That slot is, thanks to the above specialization of effective-slot-definition-class, an instance of monitored-effective-slot-definition.
Next, you check whether or not any of the direct slot definitions for this slot are instances of monitored-direct-slot-definition. Recall that, because of your specialization of the direct-slot-definition-class method, a particular direct slot will be an instance of monitored-direct-slot-definition only in the case where you included :monitored t among the slot options for that slot. (😕)
Finally, recalling that effective slot definitions are objects with slots of their own, you set the monitored slot to t when appropriate.

Great! Now everything is in place for you to define something like the person class at the top of the post. But one thing is missing, the actual execution of code when your monitored slots change.

`slot-value-using-class`

In order to customize how slot access behaves for instances of classes with custom metaclasses, the MOP provides slot-value-using-class.

     ;; specialize on setf b/c you only want to monitor changes  
     (defmethod (setf closer-mop:slot-value-using-class) :around  
         (new-value class object (slot monitored-effective-slot-definition))  
       (when (slot-value slot 'monitored)  
         (let* ((name  
                  (closer-mop:slot-definition-name slot))  
                (orig-value  
                  (when (slot-boundp object name)  
                    (slot-value object name))))  
           (on-slot-set object name orig-value new-value)))  
       (call-next-method))

Which is specialized on the custom effective slot class monitored-effective-slot-definition. It first checks if the slot is monitored, and, if it is, gets its name and its current value. It then calls the on-slot-set method before performing its usual function via call-next-method.

And that's it! At this point, all of the mechanics for running custom code when an object changes are in place. But.. why might you want to?

Applications

As I teased in the introduction the technique presented in this post opens up to a wide range of possible applications. So, without ado:

Observer Pattern

A possible implementation of the Observer Pattern:

     ;; need a way to publish and subscribe:  
     (defgeneric message-received (subscriber message)  
       (:documentation "Specialzied on subscribers"))  
      
     (defclass publisher ()  
       ((subscribers :accessor subscribers :initform nil)))  
      
     ;; publishers will notify subscribers when state changes     
     (defmethod on-slot-set ((publisher publisher) slot old new)  
       (declare (ignorable slot old new))  
       (dolist (sub (subscribers publisher))  
         (message-received sub publisher)))  
      
     ;; moving points move around  
     (defclass moving-point (publisher)  
       ((x :accessor px :initform 0 :monitored t)  
        (y :accessor py :initform 0 :monitored t))  
       (:metaclass monitored-class))  
      
     ;; boundaries subscribe to moving points  
     ;; and change state whena point enters or leaves  
     (defclass boundary ()  
       ((left :initarg :left)  
        (right :initarg :right)  
        (top  :initarg :top)  
        (bottom :initarg :bottom)  
        (contained :reader contained :initform nil)))  
      
     ;; specialize message-received for boundary  
     (defmethod message-received ((boundary boundary) message)  
       (let ((pt (getf message :object)))  
         (with-slots (left right top bottom contained) boundary  
           (if  (and (<= left (px pt) right)  
                     (<= top (py pt) bottom))  
                (pushnew pt contained)  
                (setf contained (remove pt contained))))))  
      
     (defvar *boundary* (make-instance 'boundary :left 10 :right 20 :top 0 :bottom 100))  
     (defvar *pt* (make-instance 'moving-point))  
      
     (push (subscribers *pt*) *boundary*)  
      
     (setf (px *pt*) 15  
           (py *pt*) 50)  
      
     (member *pt* (contained *boundary*)) ;; t

Memento Pattern

A version of a memento-like pattern can also be achieved:

    ;; superclass for classes whose instances  
         ;; can roll-back  
     (defclass change-log ()  
       ((change-log :initform nil)))  
      
     (defun rollback (ob)  
       (let ((last-change (pop (slot-value ob 'change-log))))  
         (when last-change  
           (setf (slot-value ob (getf last-change :slot))  
                 (getf last-change :old-value))  
           ;; because the setf would have added  
           ;; a new change to the log, you pop it off  
           (pop (slot-value ob 'change-log))))  
       ;; whatever the case, return the original object  
       ob)  
      
     (defmethod on-slot-set ((ob change-log) name old new)  
       (declare (ignorable new))  
       (push (list :slot name :old-value old)  
             (slot-value ob 'change-log)))  
      
     (defclass rewindable-point (change-log)  
       ((x :accessor px :initarg :x :monitored t)  
        (y :accessor py :initarg :y :monitored t))  
       (:metaclass monitored-class))

The above is a rather naive implementation, and assumes you want to track all changes to monitored slots for all time. A better version might cap the length of the change log.

The idea works though. You can make changes to instances of rewindable-point and, if you choose, call rollback to get a previous version.

I'd Better Wrap Up

This post is getting rather long so I'd better wrap up. I should point out the invaluable work of the folks who made bknr.datastore, work which I studied intently while learning the ins-and-outs of MOP discussed above.

I hope you have enjoyed this third installment of CLOS-Encounters!