history class

history-class.lisp

(defpackage #:snippets/history-class
  (:use #:cl #:closer-mop)
  (:shadowing-import-from
   #:closer-mop
   #:standard-generic-function
   #:defgeneric
   #:defmethod)
  (:import-from
   #:fset)
  (:export
   #:history-class
   #:slot-history
   #:slot-undo
   #:atomic))

(in-package #:snippets/history-class)

;;;; History Class
;;
;; A history class maintains a record of historical values for slots.
;;
;; The idea is from [0].  Some of the design follows [1].
;;
;; The maximum number of values saved is determined by an
;; :HISTORY-MAX-DEPTH slot initarg.  The default maximum depth is
;; zero, i.e. no history is maintained.  When multiple max-depth
;; values exist for the same slot, the maximum value is used.
;;
;; Use SLOT-HISTORY to query for the list of previous values for a
;; slot.
;;
;; Use SLOT-UNDO to set a slot's value to the most recent value in the
;; history list.  The value is then removed from the list.  The value
;; of the slot prior to the undo operation is lost.
;;
;; Use ATOMIC to disable saving values in the history list for the
;; extent of the body's evaluation, for the slots given in the slot
;; specification.
;;
;; [0] http://rosettacode.org/wiki/History_variables
;;
;; [1] Mallon, Takaoka, "History Variables: The Semantics, Formal
;;     Correctness, and Implementation of History Variables in an
;;     Imperative Programming Language" (2006)
;;     http://dx.doi.org/10.26021/2692
;;
;; Issues:
;;
;; The current implementation assumes :INSTANCE slot allocation.
;;
;; The current implementation uses a weak hash table (SBCL-specific)
;; to store slot history lists for the various instances.  Is there a
;; better way?
;;
;; I'm unsure about the name "history class".
;;
;; When a slot is missing, an error is signaled.  CLHS says
;; SLOT-MISSING is not for a user to call, so we don't.  Does CLHS
;; refer to all users, including users of the MOP?
;;
;; If multiple superclasses provide different max-depths, the maximum
;; value will be used, but a user should likely be able to override it
;; by providing a bottom-most max-depth.

(defclass history-class (standard-class)
  ())

(defgeneric slot-history-using-class (class object slotd))

(defgeneric slot-undo-using-class (class object slotd))

(defmethod validate-superclass ((class history-class) (superclass standard-class))
  t)

(defclass history-direct-slot-definition (standard-direct-slot-definition)
  ((max-depth :initarg :history-max-depth))
  (:default-initargs :history-max-depth 0))

(defmethod direct-slot-definition-class ((class history-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'history-direct-slot-definition))

(defclass history-effective-slot-definition (standard-effective-slot-definition)
  ((max-depth :initform 0)
   (previous-values :initform (make-hash-table :test 'eq :weakness :key))))

(defmethod effective-slot-definition-class ((class history-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'history-effective-slot-definition))

(defmethod compute-effective-slot-definition ((class history-class) name dslotds)
  (let ((eslotd (call-next-method)))
    (when (typep eslotd 'history-effective-slot-definition)
      (let ((max-depth (reduce (lambda (m dslotd)
                                 (max m
                                      (if (typep dslotd 'history-direct-slot-definition)
                                          (slot-value dslotd 'max-depth)
                                          0)))
                               dslotds
                               :initial-value 0)))
        (setf (slot-value eslotd 'max-depth) max-depth)))
    eslotd))

(defvar *history-save-values*
  (fset:empty-map t))

(defmacro without-history (&body forms)
  `(let ((*history-save-values* (fset:empty-map nil)))
     ,@forms))

(defmethod (setf slot-value-using-class) :before (new-value
                                                  (class history-class)
                                                  object
                                                  (slotd history-effective-slot-definition))
  (declare (ignore new-value))
  (when (plusp (slot-value slotd 'max-depth))
    (when (fset:lookup *history-save-values* (list object (slot-definition-name slotd)))
      (when (slot-boundp-using-class class object slotd)
        (let ((old-value (slot-value-using-class class object slotd)))
          (slot-history-push-using-class class object slotd old-value))))))

(defmethod slot-history-push-using-class ((class history-class)
                                          object
                                          (slotd history-effective-slot-definition)
                                          value)
  (let ((max-depth (slot-value slotd 'max-depth))
        (previous-values (slot-value slotd 'previous-values)))
    (when (plusp max-depth)
      (symbol-macrolet ((object-previous-values (gethash object previous-values)))
        (when (null object-previous-values)
          (setf object-previous-values (fset:empty-seq)))
        (loop while (<= max-depth (fset:size object-previous-values))
              do (setf object-previous-values (fset:less-last object-previous-values)))
        (setf object-previous-values (fset:with-first object-previous-values value))))))

(defun get-class-and-slotd (object slot-name)
  (let* ((class (class-of object))
         (slots (class-slots class))
         (slotd (find slot-name slots :key #'slot-definition-name)))
    (when (null slotd)
      (error "Object ~S has no slot named ~S." object slot-name))
    (values class slotd)))

(defmethod slot-history-push ((object standard-object) slot-name value)
  (multiple-value-bind (class slotd) (get-class-and-slotd object slot-name)
    (slot-history-push-using-class class object slotd value)))

(defmethod slot-history-using-class ((class standard-class) object slotd)
  (declare (ignore object slotd))
  '())

(defmethod slot-history-using-class ((class history-class)
                                     object
                                     (slotd history-effective-slot-definition))
  (let ((previous-values (slot-value slotd 'previous-values)))
    (fset:convert 'list (gethash object previous-values))))

(defmethod slot-history ((object standard-object) slot-name)
  (multiple-value-bind (class slotd) (get-class-and-slotd object slot-name)
    (slot-history-using-class class object slotd)))

(defmethod slot-undo-using-class ((class standard-class) object slotd)
  (declare (ignore object slotd)))

(defmethod slot-undo-using-class ((class history-class)
                                  object
                                  (slotd history-effective-slot-definition))
  (let ((previous-values (slot-value slotd 'previous-values)))
    (symbol-macrolet ((object-previous-values (gethash object previous-values)))
      (when (and object-previous-values
                 (fset:nonempty? object-previous-values))
        (multiple-value-bind (old-value bound)
            (if (slot-boundp-using-class class object slotd)
                (values (slot-value-using-class class object slotd) t)
                (values nil nil))
          (let ((new-value (fset:first object-previous-values)))
            (without-history
              (setf (slot-value-using-class class object slotd) new-value))
            (setf object-previous-values
                  (fset:less-first object-previous-values))
            (values new-value old-value bound)))))))

(defmethod slot-undo ((object standard-object) slot-name)
  (multiple-value-bind (class slotd) (get-class-and-slotd object slot-name)
    (slot-undo-using-class class object slotd)))

(defmacro atomic ((&rest slot-specifications) &body forms)
  (if (null slot-specifications)
      `(progn ,@forms)
      (let ((gobject (gensym))
            (gslot-name (gensym))
            (old-value (gensym)))
        (destructuring-bind (object slot-name) (first slot-specifications)
          `(let* ((,gobject ,object)
                  (,gslot-name ,slot-name)
                  (,old-value (slot-value ,gobject ,gslot-name)))
             (unwind-protect
                  (let ((*history-save-values*
                          (fset:with *history-save-values*
                                     (list ,gobject ,gslot-name)
                                     nil)))
                    (atomic ,(rest slot-specifications)
                      ,@forms))
               (when (and (fset:lookup *history-save-values* (list ,gobject ,gslot-name))
                          (not (eql ,old-value (slot-value ,gobject ,gslot-name))))
                 (slot-history-push ,gobject ,gslot-name ,old-value))))))))

;;;; Tests

(defclass fib-state ()
  ((f :initform 0 :history-max-depth 1))
  (:metaclass history-class))

(defun test-fib (n)
  (let ((state (make-instance 'fib-state)))
    (with-slots (f) state
      (setf f 1)
      (loop for i from 1 to n
            do (setf f (+ f (first (slot-history state 'f)))))
      f)))

(defclass counter ()
  ((value :initform 0 :accessor counter-value :history-max-depth 10))
  (:metaclass history-class))

(defmethod print-object ((counter counter) stream)
  (print-unreadable-object (counter stream :type t)
    (format stream "~D" (slot-value counter 'value)))
  counter)

(defun test-count (n)
  (let ((counter (make-instance 'counter)))
    (loop repeat n
          do (incf (counter-value counter)))
    ;; oops
    (incf (counter-value counter))
    ;; undo
    (slot-undo counter 'value)
    counter))

(defclass x-state ()
  ((x :history-max-depth 2))
  (:metaclass history-class))

(defun test-atomic-5.3 ()
  (let ((state (make-instance 'x-state)))
    (with-slots (x) state
      (setf x 1)
      (setf x 2)
      (setf x 3)
      (atomic ((state 'x))
        (incf x)
        (incf x (first (slot-history state 'x)))
        (incf x 2))
      (assert (= x 8))
      (assert (equal (slot-history state 'x) '(3 2)))
      'ok)))

(defclass xy-state ()
  ((x :history-max-depth 2)
   (y :history-max-depth 2))
  (:metaclass history-class))

(defun test-atomic-5.4 ()
  (let ((state (make-instance 'xy-state)))
    (with-slots (x y) state
      (setf x 1)
      (setf x 2)
      (setf x 3)
      (setf y 1)
      (setf y 2)
      (setf y 3)
      (atomic ((state 'x))
        (setf x 4)
        (atomic ((state 'y))
          (setf y 4)
          (setf y 5)
          (setf x 5))
        (setf x 6)
        (setf y 6))
      (assert (= x 6))
      (assert (equal '(3 2) (slot-history state 'x)))
      (assert (= y 6))
      (assert (equal '(5 3) (slot-history state 'y)))
      'ok)))