Slime inspector customization (Common Lisp development)

Question

Here follows Common Lisp code, using a datastore library named bknr.datastore

(ql:quickload :bknr.datastore)

(defclass userdata (bknr.datastore:store-object)
  ((email :initarg :email
      :index-type bknr.indices:unique-index
      :index-values all-users)
   (name :initarg :name))
  (:metaclass bknr.datastore:persistent-class))

(let ((object-subsystem (make-instance 'bknr.datastore:store-object-subsystem)))
  (make-instance 'bknr.datastore:store
         :directory *default-pathname-defaults*
                 :subsystems (list object-subsystem)))

(make-instance 'userdata :email "[email protected]" :name "Maria")
(make-instance 'userdata :email "[email protected]" :name "Katerina")

(setf (slot-value (first (all-users)) 'name) "Elena")
; Attempt to modify persistent slot NAME of #<USERDATA ID: 0> outside of a transaction
;   [Condition of type BKNR.DATASTORE::PERSISTENT-SLOT-MODIFIED-OUTSIDE-OF-TRANSACTION]

(bknr.datastore:with-transaction ()
  (setf (slot-value (first (all-users)) 'name) "Elena"))
; runs successfully, the above wrap in with-transaction () is necessary

I use the Slime inspector to view the datastore, so in the minibuffer after C-c C-I Inspect value (evaluated): I input

(all-users)

I can see the data but not edit it in the slime inspector, because the same condition is thrown as above.

Can the slime inspector be customized in a way that it wraps calls to setf inside transactions?

PS: if you run the above code, a directory named "current" will be created in your lisp's working directory. It saves the datastore on disk.

Answer 1

Not sure if that's applicable here, but there is a chance to do that on the CLOS level, if the CLOS implementation supports the meta-object protocol (MOP).

Using Clozure CL - a Common Lisp implementation - here. This maybe a little bit different depending on the implementation.

; we need to define a new meta-class, which is a subclass from
; standard-class, the class of standard classes.
(defclass my-standard-class (standard-class) ())

; we need to tell CLOS that this is a valid superclass
(defmethod validate-superclass ((class my-standard-class)
                                (superclass standard-class))
  t)

; note that in your example the USERDATA class already
; has a different metaclass, so above would not be necessary
; and one probably could use that metaclass in the example below.

; now we define our class with one slot and the specific metaclass.
; The class foobar, will be an instance of class my-standard-class

(defclass foobar () ((a :initform 21))
  (:metaclass my-standard-class))

; the CLOS MOP provides a generic function named (setf slot-value-using-class).
; this method will be called by setting the slot-value.
; But one can not extend it
;  with new methods. But (setf slot-value-using-class) is
;  a generic function and we can extend it.

(defmethod (setf slot-value-using-class) :around 
  (value
   (class my-standard-class)
   object
   slot)
  (with-something ()
    (call-next-method)))

Above function will be called with four arguments:

• the new value
• the class
• the instance
• the slot

Thus a call to

   (setf (slot-value (make-instance 'foobar) 'a) 42)

would run above :around method.

The method is an :around method and we can wrap our WITH-SOMETHING macro around the call of the next method. Replace the WITH-SOMETHING for example with a macro call which ensures a transaction. This then would mean that all uses of setting the SLOT-VALUE for classes of this metaclass will run in a transaction. You can also further specify the class or type of the value, to ensure that the transaction is only used for certain types of values.

(setf (slot-value (make-instance 'foobar) 'a) 42)

This would mean that anything which tries to set such a slot for instances of our metaclass using the (SETF SLOT-VALUE) form will use a transaction - even something like an external inspector, which would update the slot of such an instance.

Note that (setf slot-value-using-clss) is really a function name:

? #'(setf slot-value-using-class)
#<STANDARD-GENERIC-FUNCTION (SETF SLOT-VALUE-USING-CLASS) #x30200002C50F>