6d0aa5eb |
1 | (in-package :lisp-on-lines) |
2 | |
3 | (define-layered-class simple-plist-attribute () |
4 | (%property-access-function |
5 | (description-class :initarg description-class |
6 | :accessor attribute-description-class)) |
7 | (:documentation "A very simple implementation of ATTRIBUTEs based on |
8 | simple plists. |
9 | |
10 | To implement layered slot values, we use an anonymous layered function |
11 | with a combination of APPEND. Methods on different layers return a |
12 | plist (which is APPENDed), from which we simply GETF for the slot |
13 | value. |
14 | |
15 | This is ineffecient, of course, but is easy to understand. Caching and |
16 | performance hacks are implemented in subclasses that extend the simple |
17 | protocol we define here.")) |
18 | |
19 | (defstruct static-attribute-slot value) |
20 | |
21 | (defmethod ensure-property-access-function ((attribute simple-plist-attribute)) |
22 | "return the PROPERTY-ACCESS-FUNCTION of this attribute. FUNCALLing |
23 | the returned symbol will return the plist of slot values." |
24 | (if (slot-boundp attribute '%property-access-function) |
25 | (slot-value attribute '%property-access-function) |
26 | (let ((fn-name (gensym))) |
27 | (ensure-layered-function fn-name :lambda-list '(description) :method-combination '(append)) |
28 | (setf (slot-value attribute '%property-access-function) fn-name)))) |
29 | |
30 | (defun property-access-value (attribute) |
31 | (ignore-errors (funcall (ensure-property-access-function attribute) (attribute-description attribute)))) |
32 | |
33 | (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator= |
34 | "A default value for GETF to return.") |
35 | |
36 | (defvar *special-symbol-access* nil) |
37 | |
38 | (defun special-symbol-access-p () |
39 | *special-symbol-access*) |
40 | |
41 | (defmacro with-special-symbol-access (&body body) |
42 | `(let ((*special-symbol-access* t)) |
43 | ,@body)) |
44 | |
45 | (defmacro without-special-symbol-access (&body body) |
46 | `(let ((*special-symbol-access* nil)) |
47 | ,@body)) |
48 | |
49 | (define-layered-method |
50 | contextl:slot-value-using-layer (class (attribute simple-plist-attribute) slotd reader) () |
51 | "Only layered slots that are not currently dynamically rebound are looked up via the plist. |
52 | Initial slot values are stored in the PLIST of the symbol ENSURE-PROPERTY-ACCESS-FUNCTION returns." |
53 | |
54 | (if (or contextl:*symbol-access* |
55 | (special-symbol-access-p) |
56 | (not (slot-definition-layeredp slotd))) |
57 | (call-next-method) |
58 | (multiple-value-bind (value boundp) |
59 | (handler-case (values (call-next-method) t) |
60 | (unbound-slot () (values nil nil))) |
61 | |
62 | (when (and boundp (not (static-attribute-slot-p value))) |
63 | (return-from slot-value-using-layer value)) |
64 | |
65 | (let ((dynamic-value |
66 | (getf (ignore-errors (funcall (ensure-property-access-function attribute) |
67 | (find-layer (slot-value attribute 'description-class)))) |
68 | |
69 | (slot-definition-name slotd) |
70 | +property-not-found+))) |
71 | |
72 | (if (eq dynamic-value +property-not-found+) |
73 | (if boundp |
74 | (static-attribute-slot-value value) |
75 | (call-next-method)) |
76 | dynamic-value))))) |
77 | |
78 | (defun set-property-value-for-layer (attribute property value layer) |
79 | (let ((vals (property-access-value attribute))) |
80 | (ensure-layered-method |
81 | (ensure-property-access-function attribute) |
82 | `(lambda (description-class) |
83 | ',(append (list property value) (alexandria:remove-from-plist vals property))) |
84 | :specializers (list (class-of (attribute-description attribute))) |
85 | :qualifiers '(append) |
86 | :in-layer layer))) |
87 | |
88 | (define-layered-method |
89 | (setf contextl:slot-value-using-layer) :around (value class (attribute simple-plist-attribute) slotd writer) |
90 | "This might not be here" |
91 | (if (and (not contextl:*symbol-access*) |
92 | (not (special-symbol-access-p)) |
93 | (slot-definition-layeredp slotd)) |
94 | (with-special-symbol-access (setf (slot-value-using-layer class attribute slotd writer) (make-static-attribute-slot :value value))) |
95 | (call-next-method)) |
96 | ) |
97 | |
98 | (defmethod initialize-attribute-for-description (description-class (attribute simple-plist-attribute) layer-name &rest args) |
99 | "Define a method on the PROPERTY-ACCESS-FUNCTION to associate |
100 | slots (named by their :initarg) with values in layer LAYER-NAME." |
101 | (let* ((class (class-of attribute)) |
102 | (slotds (class-slots class))) |
103 | (setf (slot-value attribute 'description-class) description-class) |
104 | (ensure-layered-method |
105 | (ensure-property-access-function attribute) |
106 | `(lambda (description-class) |
107 | ',(alexandria:remove-from-plist |
108 | (loop |
109 | :for (key val) :on args :by #'cddr |
110 | :nconc (list |
111 | (loop |
112 | :for slotd :in slotds |
113 | :do (when (find key (slot-definition-initargs slotd)) |
114 | (return (slot-definition-name slotd)))) |
115 | val)) |
116 | nil)) |
117 | :specializers (list description-class) |
118 | :qualifiers '(append) |
119 | :in-layer layer-name))) |
120 | |