POC Objective C style KVO in common lisp.

gistfile1.lisp

(ql:quickload '(:closer-mop :alexandria))
;;; see end of file for an example usage


(defpackage :kvo (:use :closer-common-lisp :closer-mop :alexandria))
(in-package :kvo)


(defclass %o ()
  ((observers :accessor observers :initform (make-hash-table :test 'eq))))


(defgeneric object-will-change-property (self object property-name value) 
  (:method (self object property-name value)
    (format t "~A observes that ~A will change ~A to ~A~%"
            self object property-name value)))

(defgeneric object-did-change-property (self object property-name value) 
  (:method (self object property-name value)
    (format t "~A observes that ~A did change ~A to ~A~%"
            self object property-name value)))

(defgeneric will-change (o p v)
  (:method (o p v) (format t "~A will change ~A to ~A~%" o p v))
  (:method ((self %o) p v)
    (call-next-method)
    (dolist (observer (gethash p (observers self)))
      (object-will-change-property observer self p v))))

(defgeneric did-change (o p v)
  (:method (o p v) (format t "~A did change ~A to ~A~%" o p v))
  (:method ((self %o) p v)
    (call-next-method)
    (dolist (observer (gethash p (observers self)))
      (object-did-change-property observer self p v))))


(defun add-fn-for-setf-property-of-class (fn property-name class-name)
  (let* ((gf (fdefinition `(setf ,property-name)))
         (class (find-class class-name))
         (method-class (generic-function-method-class gf))
         (prototype (class-prototype method-class))
         (method-lambda (make-method-lambda gf prototype
                                            `(lambda (value object)
                                               (funcall (function ,fn) value object))
                                            nil))
         (method (make-instance method-class
                                :qualifiers nil
                                :lambda-list '(value object)
                                :specializers (list (find-class t) class)
                                :function (coerce method-lambda 'function))))
    (add-method gf method)))


(defun %observable-class-name (object)
  (let ((*package*  #.(find-package :keyword)))
    (intern (format nil "kvo%observable ~S"
                    (class-name (class-of object))) #.(find-package :kvo))))

(defun %observable-p (object)
  (typep object '%o))

(defun %observable-class-for-object (object)
  (check-type object standard-object)
  (let ((original-class-name (class-name (class-of object)))
        (name (%observable-class-name object)))
    (or (find-class name nil)
        (ensure-class name
                      :direct-superclasses `(%o ,original-class-name)))))

(defun %ensure-property-is-observable (object property)
  (unless (find-method (fdefinition `(setf ,property))
                       nil (list (find-class t) (class-of object)) nil)
    (add-fn-for-setf-property-of-class `(lambda (v o)
                                          (will-change o ',property v)
                                          (multiple-value-prog1 (call-next-method)
                                            (did-change o ',property v)))
                                       property
                                       (class-name (class-of object)))))

(defun %become-observable (object)
  (check-type object standard-object)
  (unless (%observable-p object)
    (change-class object (%observable-class-for-object object))))

(defgeneric add-observer-for-property (object observer property-name)
  (:method ((object standard-object) observer property-name)
    (%become-observable object)
    (add-observer-for-property object observer property-name))
  (:method ((self %o) observer property-name)
    (%ensure-property-is-observable self property-name)
    (push observer (gethash property-name (observers self)))))

(defgeneric remove-observer-for-property (object observer property-name)
  (:method ((self %o) observer property-name)
    (deletef (gethash property-name (observers self)) observer)))


;;--------------------------------------------------------------------------------
;; example usage:

(defclass c ()
  ((property :accessor property :initform nil)))

(defvar *observed (make-instance 'c))

(defvar *observer '(any old thing))

(add-observer-for-property *observed *observer 'property)

;;; KVO> (class-of *observed)
;;;  #<COMMON-LISP:STANDARD-CLASS |kvo%observable KVO::C|>
;;; KVO> (setf (property *observed) 'foo)
;;; #<kvo%observable KVO::C #x3020013C3DAD> will change PROPERTY to FOO
;;; (ANY OLD THING) observes that #<kvo%observable KVO::C #x3020013C3DAD> will change PROPERTY to FOO
;;; #<kvo%observable KVO::C #x3020013C3DAD> did change PROPERTY to FOO
;;; (ANY OLD THING) observes that #<kvo%observable KVO::C #x3020013C3DAD> did change PROPERTY to FOO
;;; FOO
;;; KVO> (property *observed)
;;; FOO
;;; KVO>