d1a7fc5a |
1 | (in-package :lisp-on-lines) |
2 | |
3 | (setf (find-class 'simple-attribute nil) nil) |
4 | |
5 | (define-layered-class simple-attribute () |
6 | ((%property-access-function |
7 | :initarg property-access-function))) |
8 | |
9 | (defun ensure-property-access-function (attribute) |
10 | (if (slot-boundp attribute '%property-access-function) |
11 | (slot-value attribute '%property-access-function) |
12 | (let ((fn-name (gensym))) |
13 | (ensure-layered-function fn-name :lambda-list '() :method-combination '(append)) |
14 | (setf (slot-value attribute '%property-access-function) fn-name)))) |
15 | |
16 | (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=) |
17 | |
18 | (define-layered-method |
19 | contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) |
20 | (if (or *symbol-access* |
21 | (eq (slot-definition-name slotd) |
22 | '%property-access-function) |
23 | (not (slot-definition-layeredp slotd))) |
24 | (call-next-method) |
25 | (let ((value (getf (funcall (ensure-property-access-function attribute)) |
26 | (slot-definition-name slotd) |
27 | +property-not-found+))) |
28 | (if (eq value +property-not-found+) |
29 | (call-next-method) |
30 | value)))) |
31 | |
32 | (defvar *test-attribute-definitions* |
33 | `((t :label "foo" :value "foo") |
34 | (simple-test-layer :label "BAZ" :value "BAZ"))) |
35 | |
36 | (defmethod initialize-attribute-for-layer (attribute layer-name &rest args) |
37 | (let* ((class (class-of attribute)) |
38 | (slotds (class-slots class))) |
39 | |
40 | (ensure-layered-method |
41 | (ensure-property-access-function attribute) |
42 | `(lambda () |
43 | ',(loop |
44 | :for (key val) :on args :by #'cddr |
45 | :nconc (list |
46 | (loop :for slotd :in slotds |
47 | :do (when (find key (slot-definition-initargs slotd)) |
48 | (return (slot-definition-name slotd)))) |
49 | val))) |
50 | :qualifiers '(append) |
51 | :in-layer layer-name))) |
52 | |
53 | |
54 | |
55 | (define-layered-class simple-standard-attribute (simple-attribute) |
56 | ((label |
57 | :layered-accessor attribute-label |
58 | :initarg :label |
59 | :initform nil |
60 | :layered t |
61 | :special t) |
62 | (label-formatter |
63 | :layered-accessor attribute-label-formatter |
64 | :initarg :label-formatter |
65 | :initform nil |
66 | :layered t |
67 | :special t) |
68 | (function |
69 | :initarg :function |
70 | :layered-accessor attribute-function |
71 | :layered t |
72 | :special t) |
73 | (value |
74 | :layered-accessor attribute-value |
75 | :initarg :value |
76 | :layered t |
77 | :special t) |
78 | (value-formatter |
79 | :layered-accessor attribute-value-formatter |
80 | :initarg :value-formatter |
81 | :initform nil |
82 | :layered t |
83 | :special t) |
84 | (activep |
85 | :layered-accessor attribute-active-p |
86 | :initarg :active |
87 | :initform t |
88 | :layered t |
89 | :special t |
90 | :documentation |
91 | "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") |
92 | (active-attributes :layered-accessor attribute-active-attributes |
93 | :initarg :attributes |
94 | :layered t |
95 | :special t) |
96 | (active-descriptions :layered-accessor attribute-active-descriptions |
97 | :initarg :activate |
98 | :initform nil |
99 | :layered t |
100 | :special t) |
101 | (inactive-descriptions :layered-accessor attribute-inactive-descriptions |
102 | :initarg :deactivate |
103 | :initform nil |
104 | :layered t |
105 | :special t))) |
106 | |
107 | |
108 | (define-layered-class direct-attribute-slot-definition-class |
109 | (special-layered-direct-slot-definition |
110 | contextl::singleton-direct-slot-definition) |
111 | ((attribuite-properties |
112 | :accessor slot-definition-attribute-properties |
113 | :documentation "Holds the initargs passed to the slotd"))) |
114 | |
115 | (defmethod initialize-instance |
116 | :after ((slotd direct-attribute-slot-definition-class) |
117 | &rest initargs) |
118 | (setf (slot-definition-attribute-properties slotd) initargs)) |
119 | |
120 | (defmethod reinitialize-instance |
121 | :after ((slotd direct-attribute-slot-definition-class) |
122 | &rest initargs) |
123 | (setf (slot-definition-attribute-properties slotd) initargs)) |
124 | |
125 | (define-layered-class effective-attribute-slot-definition-class |
126 | (special-layered-effective-slot-definition) |
127 | ((attribute-object |
128 | :accessor slot-definition-attribute-object))) |
129 | |
130 | (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class) |
131 | ((defined-in-descriptions :initarg :in-description) |
132 | (class-active-attributes-definition :initarg :attributes) |
133 | (mixin-class-p :initarg :mixinp))) |
134 | |
135 | (defmethod direct-slot-definition-class |
136 | ((class description-access-class) &key &allow-other-keys) |
137 | (find-class 'direct-attribute-slot-definition-class)) |
138 | |
139 | (defmethod effective-slot-definition-class |
140 | ((class description-access-class) &key &allow-other-keys) |
141 | (find-class 'effective-attribute-slot-definition-class)) |
142 | (fmakunbound 'initialize-slot-definition-attribute) |
143 | (defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions) |
144 | (let ((tbl (make-hash-table)) |
145 | (attribute (make-instance 'simple-standard-attribute :name name))) |
146 | (loop for ds in direct-slot-definitions |
147 | :do (setf (gethash (slot-definition-layer ds) tbl) |
148 | (append (gethash (slot-definition-layer ds) tbl '()) |
149 | (slot-definition-attribute-properties ds)))) |
150 | (maphash (lambda (layer properties) |
151 | (apply #'initialize-attribute-for-layer attribute layer properties)) |
152 | tbl) |
153 | (setf (slot-definition-attribute-object slotd) attribute))) |
154 | |
155 | (defmethod compute-effective-slot-definition |
156 | ((class description-access-class) name direct-slot-definitions) |
157 | (declare (ignore name)) |
158 | (let ((slotd (call-next-method))) |
159 | (initialize-slot-definition-attribute slotd) |
160 | slotd)) |
161 | |
162 | (defclass standard-description-class (description-access-class layered-class) |
163 | ((attributes :accessor description-class-attributes :initform (list))) |
164 | (:default-initargs :defining-metaclass 'description-access-class)) |
165 | |
166 | (defmethod validate-superclass |
167 | ((class standard-description-class) |
168 | (superclass standard-class)) |
169 | t) |
170 | |
171 | (define-layered-class standard-description-object (standard-layer-object) |
172 | ((described-object :accessor described-object |
173 | :special t))) |
174 | |
175 | (defun initialize-description-class-attribute (description attribute initargs) |
176 | ) |
177 | |
178 | (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) |
179 | (declare (dynamic-extent initargs)) |
180 | (prog1 |
181 | (if (loop for direct-superclass in direct-superclasses |
182 | thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))) |
183 | (call-next-method) |
184 | (apply #'call-next-method |
185 | class |
186 | :direct-superclasses |
187 | (append direct-superclasses |
188 | (list (find-class 'standard-description-object))) |
189 | initargs)) |
190 | (break "initializing ~A ~A" class initargs))) |
191 | |
192 | |
193 | (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) |
194 | (declare (dynamic-extent initargs)) |
195 | ; (warn "CLASS ~A ARGS ~A:" class initargs) |
196 | (prog1 |
197 | (if (or (not direct-superclasses-p) |
198 | (loop for direct-superclass in direct-superclasses |
199 | thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))) |
200 | (call-next-method) |
201 | (apply #'call-next-method |
202 | class |
203 | :direct-superclasses |
204 | (append direct-superclasses |
205 | (list (find-class 'standard-description-object))) |
206 | initargs)) |
207 | (break "RE-initializing ~A ~A" class initargs))) |
208 | |
209 | (defmethod finalize-inheritance :after ((class standard-description-class)) |
210 | (break "Finalizing ~S" (class-name class))) |
211 | |
212 | ;;;; A simpler implementation of descriptions based on plists |
213 | |
214 | |
215 | |