remobe ROFL and add validation
[clinton/lisp-on-lines.git] / src / attribute.lisp
CommitLineData
e7c5f95a 1(in-package :lisp-on-lines)
2
4358148e 3(define-layered-class direct-attribute-definition-class
6de8d300 4 (special-layered-direct-slot-definition
5 contextl::singleton-direct-slot-definition)
6 ((attribute-properties
7 :accessor direct-attribute-properties
8 :documentation "This is an plist to hold the values of
9 the attribute's properties as described by this direct
10 attribute definition.")))
11
12(defmethod initialize-instance
13 :after ((attribute direct-attribute-definition-class)
14 &rest initargs)
15 (setf (direct-attribute-properties attribute) initargs))
16
17(define-layered-class effective-attribute-definition-class
18 (special-layered-effective-slot-definition)
19 ((direct-attributes
20 :accessor attribute-direct-attributes)
21 (attribute-object
e8d4fa45 22 :accessor slot-definition-attribute-object)
6de8d300 23 (attribute-object-initargs
24 :accessor attribute-object-initargs)))
25
26(defvar *function-access* nil
27 "set/get a place's property function instead of its symbol value
28 when this is set to a non-nil value")
29
30(defmacro with-function-access (&body body)
31 "executes body in an environment with *function-access* set to t"
32 `(let ((*function-access* t))
33 ,@body))
34
35(defmacro without-function-access (&body body)
36 "executes body in an environment with *function-access* set to nil"
37 `(let ((*function-access* nil))
38 ,@body))
39
40(define-layered-function property-access-function (description attribute-name property-name)
41 (:method (description attribute-name property-name)
42 (ensure-layered-function
43 (defining-description
e8d4fa45 44 (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A="
6de8d300 45 (description-print-name description)
46 attribute-name
47 property-name)))
48 :lambda-list '(description))))
e7c5f95a 49
e7c5f95a 50
e8d4fa45 51(defvar *init-time-description* nil)
52
53(defmethod attribute-description :around (attribute)
54 (handler-case (call-next-method)
55 (unbound-slot ()
56 (or
57 *init-time-description*
b7657b86 58 (call-next-method)))))
e8d4fa45 59
60(define-layered-class attribute ()
61 ((description :initarg :description
62 :accessor attribute-description)
6de8d300 63 (name
64 :layered-accessor attribute-name
65 :initarg :name)
66 (effective-attribute-definition
67 :initarg effective-attribute
68 :accessor attribute-effective-attribute-definition)
69 (attribute-class
70 :accessor attribute-class
71 :initarg :attribute-class
e8fd1a9a 72 :initform 'standard-attribute)
e8d4fa45 73 (keyword
74 :layered-accessor attribute-keyword
75 :initarg :keyword
76 :initform nil
77 :layered t)
78 (object
79 :layered-accessor attribute-object
80 :accessor described-object
81 :special t)))
82
83
e8d4fa45 84(define-layered-class standard-attribute (attribute)
85 ((label
6de8d300 86 :layered-accessor attribute-label
87 :initarg :label
88 :initform nil
89 :layered t
90 :special t)
b7657b86 91 (label-formatter
92 :layered-accessor attribute-label-formatter
93 :initarg :label-formatter
94 :initform nil
95 :layered t
96 :special t)
6de8d300 97 (function
98 :initarg :function
99 :layered-accessor attribute-function
100 :layered t
101 :special t)
b7657b86 102 (value
103 :layered-accessor attribute-value
104 :initarg :value
105 :layered t
106 :special t)
107 (value-formatter
108 :layered-accessor attribute-value-formatter
109 :initarg :value-formatter
110 :initform nil
111 :layered t
112 :special t)
6de8d300 113 (activep
114 :layered-accessor attribute-active-p
e8d4fa45 115 :initarg :activep ;depreciated
116 :initarg :active
6de8d300 117 :initform t
118 :layered t
e8d4fa45 119 :special t
120 :documentation
b7657b86 121 "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
122 (active-attributes :layered-accessor attribute-active-attributes
123 :initarg :attributes
124 :layered t
125 :special t)
126 (active-descriptions :layered-accessor attribute-active-descriptions
127 :initarg :activate
128 :initform nil
129 :layered t
130 :special t)
131 (inactive-descriptions :layered-accessor attribute-inactive-descriptions
132 :initarg :deactivate
133 :initform nil
134 :layered t
135 :special t)))
136
c29b2d2d 137(define-layered-method attribute-active-p :around (attribute)
138 (let ((active? (call-next-method)))
139 (if (eq :when active?)
140 (not (null (attribute-value attribute)))
141 active?)))
142
b7657b86 143(define-layered-method attribute-label-formatter :around (attribute)
144 (or (slot-value attribute 'label-formatter)
145 (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
146 (error "No Formatter .. fool!")))
147
148(define-layered-method attribute-value-formatter :around (attribute)
149
150 (or (slot-value attribute 'value-formatter)
151 (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
152 (error "No Formatter .. fool!")))
153
e8d4fa45 154
155
156(define-layered-method attribute-object ((attribute standard-attribute))
157 (if (slot-boundp attribute 'object)
158 (call-next-method)
159 (described-object (attribute-description attribute))))
160
161
b7657b86 162(define-layered-function attribute-value-using-object (object attribute))
163(define-layered-function (setf attribute-value-using-object) (value object attribute))
164
e8d4fa45 165(define-layered-method attribute-value ((attribute standard-attribute))
166 (attribute-value-using-object (attribute-object attribute) attribute))
e8d4fa45 167
168(define-layered-method attribute-value-using-object (object attribute)
169 (let ((fn (handler-case (attribute-function attribute)
170 (unbound-slot () nil))))
171 (if fn
172 (funcall fn object)
173 (slot-value attribute 'value))))
6de8d300 174
b7657b86 175(define-layered-method (setf attribute-value) (value (attribute standard-attribute))
176 (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
177
178(define-layered-method (setf attribute-value-using-object) (value object attribute)
179 (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
180 object attribute))
181
182
6de8d300 183(defun ensure-access-function (class attribute property)
184 (with-function-access
185 (if (slot-definition-specialp property)
186 (let ((slot-symbol
187 (with-symbol-access
188 (slot-value-using-class
189 class attribute property))))
190 (if (fboundp slot-symbol)
191 (symbol-function slot-symbol)
192 (setf (symbol-function slot-symbol)
193 (property-access-function
194 (attribute-description attribute)
195 (attribute-name attribute)
196 (slot-definition-name property)))))
197 (if (slot-boundp-using-class class attribute property)
198 (slot-value-using-class class attribute property)
199 (setf (slot-value-using-class class attribute property)
200 (property-access-function
201 (attribute-description attribute)
202 (attribute-name attribute)
203 (slot-definition-name property)))))))
204
205(define-layered-method slot-boundp-using-layer
206 :in-layer (layer t)
207 :around (class (attribute standard-attribute) property reader)
208
209; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
210 ; (slot-definition-name property))
e7c5f95a 211
6de8d300 212 (if (or *symbol-access* *function-access*)
213 (call-next-method)
214 (or (when (slot-definition-specialp property)
215 (with-function-access
216 (slot-boundp-using-class class attribute property)))
217 (if (generic-function-methods
218 (ensure-access-function class attribute property))
219 T
220 NIL))))
e7c5f95a 221
6de8d300 222(define-layered-method (setf slot-value-using-layer)
223 :in-layer (context t)
224 :around
225 (new-value class (attribute standard-attribute) property writer)
226
227;; (dprint "Setting ~A ~A to : ~A" attribute property new-value)
e7c5f95a 228
6de8d300 229 (if (or *symbol-access* *function-access*)
230 (call-next-method)
231
232 (if (and (slot-definition-specialp property)
233 (with-function-access
234 (without-symbol-access (slot-boundp-using-class class attribute property))))
235 (with-function-access
236 (call-next-method))
237 (let ((layer
238 ;;FIXME: this is wrong for so many reasons
239 (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
240 :key #'class-name))))
241 (boundp (slot-boundp-using-class class attribute property))
242 (fn (ensure-access-function class attribute property)))
243
244 (when (not boundp)
245 ;; * This slot has never been set before.
246 ;; create a method on property-accessor-function
247 ;; so subclasses can see this new property.
248 (ensure-layered-method
249 (layered-function-definer 'property-access-function)
250 `(lambda (description attribute property)
251 (declare (ignore description attribute property))
252 ,fn)
253 :in-layer layer
254 :specializers
255 (list (class-of
256 (attribute-description attribute))
257 (closer-mop:intern-eql-specializer
258 (attribute-name attribute))
259 (closer-mop:intern-eql-specializer
260 (closer-mop:slot-definition-name property)))))
261
262 ;; specialize this property to this description.
263 ;;(dprint "actrually specializering")
264 (ensure-layered-method
265 fn
266 `(lambda (description)
267 (funcall ,(lambda()
268 new-value)))
269 :in-layer layer
270 :specializers (list (class-of (attribute-description attribute))))
271
272 ;; and return the set value as is custom
273 new-value))))
274
275(define-layered-method slot-value-using-layer
276 :in-layer (layer t)
277 :around (class (attribute standard-attribute) property reader)
278
279; ;(dprint "Getting the slot value of ~A" property)
280 (if (or *symbol-access* *function-access*)
281 (call-next-method)
282 (let ((fn (ensure-access-function class attribute property)))
283
284 (unless (slot-boundp-using-class class attribute property)
285 (slot-unbound class attribute (slot-definition-name property)))
286
287 (if (slot-definition-specialp property)
288 (if (with-function-access
289 (slot-boundp-using-class class attribute property))
290 (with-function-access
291 (slot-value-using-class class attribute property))
292 (funcall fn layer (attribute-description attribute)))
3d5707d5 293 (handler-case (funcall fn layer (attribute-description attribute))
294 (error ()
295 (warn "Error calling ~A" fn)))))))
6de8d300 296
297
298
4358148e 299
300
4358148e 301
4358148e 302(defmethod print-object ((object standard-attribute) stream)
303 (print-unreadable-object (object stream :type nil :identity t)
304 (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
305
4271ab0b 306(defgeneric eval-property-initarg (att initarg)
307 (:method ((attribute standard-attribute) initarg)
6de8d300 308 nil)
4271ab0b 309 (:method ((attribute standard-attribute) (initarg (eql :function)))
b7657b86 310 t)
311 (:method ((attribute standard-attribute) (initarg (eql :value)))
4271ab0b 312 t))
313
314(defun prepare-initargs (att args)
315 (loop
316 :for (key arg)
317 :on args :by #'cddr
318 :nconc (list key
319 (if (eval-property-initarg att key)
320 (eval arg)
321 arg))))
322
4358148e 323
4358148e 324(defun attribute-value* (attribute)
325 (attribute-value *object* attribute))
326
327(defmacro with-attributes (names description &body body)
b7657b86 328 `(let ,(loop for name in names collect
329 (list name `(find-attribute ,description ',name)))
330 ,@body))q
4358148e 331
e8d4fa45 332
4358148e 333
334
e7c5f95a 335
336
337
338
339
340
341
342
343