Properties are special now!
[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
22 :accessor attribute-object)
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
44 (intern (format nil "~A-~A-~A"
45 (description-print-name description)
46 attribute-name
47 property-name)))
48 :lambda-list '(description))))
e7c5f95a 49
e7c5f95a 50
6de8d300 51(define-layered-class standard-attribute ()
52 ((description-class :initarg description-class)
53 (name
54 :layered-accessor attribute-name
55 :initarg :name)
56 (effective-attribute-definition
57 :initarg effective-attribute
58 :accessor attribute-effective-attribute-definition)
59 (attribute-class
60 :accessor attribute-class
61 :initarg :attribute-class
62 :initform 'standard-attribute
63 :layered t)
64 (label
65 :layered-accessor attribute-label
66 :initarg :label
67 :initform nil
68 :layered t
69 :special t)
70 (function
71 :initarg :function
72 :layered-accessor attribute-function
73 :layered t
74 :special t)
75 (value
76 :layered-accessor %attribute-value
77 :initarg :value
78 :layered t
79 :special t)
80 (activep
81 :layered-accessor attribute-active-p
82 :initarg :activep
83 :initform t
84 :layered t
85 :special t)
86 (keyword
87 :layered-accessor attribute-keyword
88 :initarg :keyword
89 :initform nil
90 :layered t)
91))
92
93(defun ensure-access-function (class attribute property)
94 (with-function-access
95 (if (slot-definition-specialp property)
96 (let ((slot-symbol
97 (with-symbol-access
98 (slot-value-using-class
99 class attribute property))))
100 (if (fboundp slot-symbol)
101 (symbol-function slot-symbol)
102 (setf (symbol-function slot-symbol)
103 (property-access-function
104 (attribute-description attribute)
105 (attribute-name attribute)
106 (slot-definition-name property)))))
107 (if (slot-boundp-using-class class attribute property)
108 (slot-value-using-class class attribute property)
109 (setf (slot-value-using-class class attribute property)
110 (property-access-function
111 (attribute-description attribute)
112 (attribute-name attribute)
113 (slot-definition-name property)))))))
114
115(define-layered-method slot-boundp-using-layer
116 :in-layer (layer t)
117 :around (class (attribute standard-attribute) property reader)
118
119; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
120 ; (slot-definition-name property))
e7c5f95a 121
6de8d300 122 (if (or *symbol-access* *function-access*)
123 (call-next-method)
124 (or (when (slot-definition-specialp property)
125 (with-function-access
126 (slot-boundp-using-class class attribute property)))
127 (if (generic-function-methods
128 (ensure-access-function class attribute property))
129 T
130 NIL))))
e7c5f95a 131
6de8d300 132(define-layered-method (setf slot-value-using-layer)
133 :in-layer (context t)
134 :around
135 (new-value class (attribute standard-attribute) property writer)
136
137;; (dprint "Setting ~A ~A to : ~A" attribute property new-value)
e7c5f95a 138
6de8d300 139 (if (or *symbol-access* *function-access*)
140 (call-next-method)
141
142 (if (and (slot-definition-specialp property)
143 (with-function-access
144 (without-symbol-access (slot-boundp-using-class class attribute property))))
145 (with-function-access
146 (call-next-method))
147 (let ((layer
148 ;;FIXME: this is wrong for so many reasons
149 (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
150 :key #'class-name))))
151 (boundp (slot-boundp-using-class class attribute property))
152 (fn (ensure-access-function class attribute property)))
153
154 (when (not boundp)
155 ;; * This slot has never been set before.
156 ;; create a method on property-accessor-function
157 ;; so subclasses can see this new property.
158 (ensure-layered-method
159 (layered-function-definer 'property-access-function)
160 `(lambda (description attribute property)
161 (declare (ignore description attribute property))
162 ,fn)
163 :in-layer layer
164 :specializers
165 (list (class-of
166 (attribute-description attribute))
167 (closer-mop:intern-eql-specializer
168 (attribute-name attribute))
169 (closer-mop:intern-eql-specializer
170 (closer-mop:slot-definition-name property)))))
171
172 ;; specialize this property to this description.
173 ;;(dprint "actrually specializering")
174 (ensure-layered-method
175 fn
176 `(lambda (description)
177 (funcall ,(lambda()
178 new-value)))
179 :in-layer layer
180 :specializers (list (class-of (attribute-description attribute))))
181
182 ;; and return the set value as is custom
183 new-value))))
184
185(define-layered-method slot-value-using-layer
186 :in-layer (layer t)
187 :around (class (attribute standard-attribute) property reader)
188
189; ;(dprint "Getting the slot value of ~A" property)
190 (if (or *symbol-access* *function-access*)
191 (call-next-method)
192 (let ((fn (ensure-access-function class attribute property)))
193
194 (unless (slot-boundp-using-class class attribute property)
195 (slot-unbound class attribute (slot-definition-name property)))
196
197 (if (slot-definition-specialp property)
198 (if (with-function-access
199 (slot-boundp-using-class class attribute property))
200 (with-function-access
201 (slot-value-using-class class attribute property))
202 (funcall fn layer (attribute-description attribute)))
203 (funcall fn layer (attribute-description attribute))))))
204
205
206
207 (define-layered-function attribute-value (object attribute))
208
209 (define-layered-method attribute-value (object attribute)
4358148e 210
6de8d300 211 (let ((fn (handler-case (attribute-function attribute)
212 (unbound-slot () nil))))
213 (if fn
214 (funcall fn object)
215 (%attribute-value attribute))))
4358148e 216
217(defmethod attribute-description (attribute)
6de8d300 218 ;(break "description for ~A is (slot-value attribute 'description-name)")
219 (find-layer (slot-value attribute 'description-class))
220 #+nil (let ((name (slot-value attribute 'description-name)))
221 (when name
222 (find-description name))))
4358148e 223
224
4358148e 225
4358148e 226(defmethod print-object ((object standard-attribute) stream)
227 (print-unreadable-object (object stream :type nil :identity t)
228 (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
229
4271ab0b 230(defgeneric eval-property-initarg (att initarg)
231 (:method ((attribute standard-attribute) initarg)
6de8d300 232 nil)
4271ab0b 233 (:method ((attribute standard-attribute) (initarg (eql :function)))
234 t))
235
236(defun prepare-initargs (att args)
237 (loop
238 :for (key arg)
239 :on args :by #'cddr
240 :nconc (list key
241 (if (eval-property-initarg att key)
242 (eval arg)
243 arg))))
244
4358148e 245
4358148e 246(defun attribute-value* (attribute)
247 (attribute-value *object* attribute))
248
249(defmacro with-attributes (names description &body body)
250 `(with-slots ,names ,description ,@body))
251
6de8d300 252(define-layered-function display-attribute (object attribute)
253 (:method (object attribute)
254 (display-using-description attribute *display* object)))
255
256(define-layered-function display-attribute-label (object attribute)
257 (:method (object attribute)
258 (format *display* "~A " (attribute-label attribute))
259))
260
261(define-layered-function display-attribute-value (object attribute)
262 (:method (object attribute)
263 (let ((val (attribute-value object attribute)))
264 (if (eq val object)
265 (format *display* "~A " val)
266 (with-active-descriptions (inline)
267 (display *display* val )
268
269 )
270 ))))
4358148e 271
e7c5f95a 272(define-layered-method display-using-description
273 ((attribute standard-attribute) display object &rest args)
4358148e 274 (declare (ignore args))
275 (when (attribute-label attribute)
6de8d300 276 (display-attribute-label object attribute))
277 (display-attribute-value object attribute))
4358148e 278
279
e7c5f95a 280
281
282
283
284
285
286
287
288