public
Last active

POC Objective C style KVO in common lisp.

  • Download Gist
gistfile1.lisp
Common Lisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
(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>

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.