Skip to content

@jaeschliman /gist:7936195
Last active

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
POC Objective C style KVO in common 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>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.