Added NULL description and added :when option for attribute active
[clinton/lisp-on-lines.git] / src / description-class.lisp
CommitLineData
4867c86f 1(in-package :lisp-on-lines)
2
4358148e 3;;;; * DESCRIPTIONS
4;;;; A description is an object which is used
5;;;; to describe another object.
6
4358148e 7
8;;; #+HACK
9;;; I'm having some 'issues' with
10;;; compiled code and my initialization.
11;;; So this hack initializes the world.
12(eval-when (:compile-toplevel :load-toplevel :execute)
13 (defparameter *defined-descriptions* nil))
14
4271ab0b 15(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
4358148e 16 ((defined-in-descriptions :initarg :in-description)
17 (mixin-class-p :initarg :mixinp)))
18
19(defmethod direct-slot-definition-class
20 ((class description-access-class) &key &allow-other-keys)
21 (find-class 'direct-attribute-definition-class))
22
23(defmethod effective-slot-definition-class
24 ((class description-access-class) &key &allow-other-keys)
25 (find-class 'effective-attribute-definition-class))
26
27(defmethod compute-effective-slot-definition
28 ((class description-access-class) name direct-slot-definitions)
4867c86f 29 (declare (ignore name))
4358148e 30 (let ((attribute (call-next-method)))
31 (setf (attribute-direct-attributes attribute) direct-slot-definitions)
f2ff8a16 32 (setf (attribute-object-initargs attribute)
33 ;; This plist will be used to init the attribute object
34 ;; Once the description itself is properly initiated.
35 (list :name name
e8d4fa45 36 'effective-attribute attribute))
4358148e 37 attribute))
e8d4fa45 38
39(defmethod slot-value-using-class ((class description-access-class) object slotd)
b7657b86 40 (call-next-method)
41#+nil (if (or
e8d4fa45 42 (eq (slot-definition-name slotd) 'described-object)
43 (not (slot-boundp slotd 'attribute-object)))
44 (call-next-method)
45 (slot-definition-attribute-object slotd)))
4867c86f 46
4358148e 47
b7657b86 48(eval-when (:compile-toplevel :load-toplevel :execute)
49 (defparameter *description-attributes* (make-hash-table)))
50
51
52
4358148e 53(defclass standard-description-class (description-access-class layered-class)
b7657b86 54 ((attributes :accessor description-class-attributes :initform (list)))
4358148e 55 (:default-initargs :defining-metaclass 'description-access-class))
56
b7657b86 57
58
4358148e 59(defmethod validate-superclass
60 ((class standard-description-class)
61 (superclass standard-class))
62 t)
63
e8d4fa45 64(define-layered-class standard-description-object (standard-layer-object)
65 ((described-object :accessor described-object
66 :special t)))
4358148e 67
68(defun description-class-name (description-class)
69 (read-from-string (symbol-name (class-name description-class))))
b7657b86 70
71(defgeneric standard-description-p (description-candidate)
72 (:method (not-description)
73 NIL)
74 (:method ((description standard-description-object))
75 T))
81d70610 76
4867c86f 77(defun initialize-description-class (class)
4358148e 78
b7657b86 79;;; HACK: initialization does not happ en properly
80;;; when compiling and loading or something like that.
81;;; Obviously i'm not sure why.
82;;; So we're going to explicitly initialize things.
83;;; For now. --drewc
84
85 (pushnew class *defined-descriptions*)
86
87;;; ENDHACK.
88
89 (let* ((description (find-layer class))
90 (attribute-objects
91 (setf (description-class-attributes (class-of description))
92 (mapcar
93 (lambda (slot)
94 (or (find-attribute description
95 (slot-definition-name slot))
96 (let* ((*init-time-description* description)
97 (attribute-class (or
98 (ignore-errors
99 (slot-value-using-class
100 (class-of description) description slot))
101 'standard-attribute))
102 (attribute
103 (apply #'make-instance
104 attribute-class
105 :description description
106 :attribute-class attribute-class
107 (attribute-object-initargs slot))))
108 (setf (slot-definition-attribute-object slot) attribute))))
109 (remove 'described-object (class-slots (class-of description))
110 :key #'slot-definition-name))))
111 (defining-classes
112 (partial-class-defining-classes class)))
113
114 (loop
115 :for (layer class)
116 :on defining-classes :by #'cddr
117 :do (funcall-with-layer-context
118 (adjoin-layer (find-layer layer) (current-layer-context))
119 (lambda ()
120 (loop :for direct-slot :in (class-direct-slots class)
121 :do (let ((attribute
122 (find (slot-definition-name direct-slot)
123 attribute-objects
124 :key #'attribute-name)))
125 (let ((initargs
126 (prepare-initargs attribute (direct-attribute-properties direct-slot))))
127
128 (apply #'reinitialize-instance attribute
129 initargs )
130 (setf (slot-value description (attribute-name attribute))
131 (attribute-class attribute))
132 (apply #'change-class attribute (attribute-class attribute)
133 initargs)))))))))
134
135
136#+old(defun initialize-description-class (class)
137
81d70610 138;;; HACK: initialization does not happ en properly
f2ff8a16 139;;; when compiling and loading or something like that.
140;;; Obviously i'm not sure why.
141;;; So we're going to explicitly initialize things.
142;;; For now. --drewc
4358148e 143
144 (pushnew class *defined-descriptions*)
6de8d300 145
f2ff8a16 146;;; ENDHACK.
4358148e 147
148 (let* ((description (find-layer class))
f2ff8a16 149 (attribute-objects
150 (mapcar
151 (lambda (slot)
e8d4fa45 152 (let* ((*init-time-description* description)
b7657b86 153 (attribute
154 (apply #'make-instance
e8d4fa45 155 'standard-attribute
156 :description description
157 (attribute-object-initargs slot))))
b7657b86 158
e8d4fa45 159
160 (setf (slot-definition-attribute-object slot) attribute)))
161 (remove 'described-object (class-slots (class-of description))
162 :key #'slot-definition-name)))
4358148e 163 (defining-classes (partial-class-defining-classes (class-of description))))
4358148e 164
4358148e 165 (loop
166 :for (layer class)
167 :on defining-classes :by #'cddr
168 :do (funcall-with-layer-context
169 (adjoin-layer (find-layer layer) (current-layer-context))
f2ff8a16 170 (lambda ()
171 (loop :for direct-slot :in (class-direct-slots class)
172 :do (let ((attribute
173 (find (slot-definition-name direct-slot)
174 attribute-objects
175 :key #'attribute-name)))
4271ab0b 176 (let ((initargs
177 (prepare-initargs attribute (direct-attribute-properties direct-slot))))
178
179 (apply #'reinitialize-instance attribute
180 initargs )
b7657b86 181 (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))
4271ab0b 182 (when (not (eq (find-class (attribute-class attribute))
183 (class-of attribute)))
b7657b86 184 (warn "~%CHANGING CLASS~%")
81d70610 185
186 (apply #'change-class attribute (attribute-class attribute)
b7657b86 187 initargs))))))))))
4358148e 188
189;;;; HACK: run this at startup till we figure things out.
190(defun initialize-descriptions ()
191 (map nil #'initialize-description-class
192 (setf *defined-descriptions*
193 (remove-duplicates *defined-descriptions*))))
194
195(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
196 (declare (dynamic-extent initargs))
197 (prog1
198 (if (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 (initialize-description-class class)))
208
209
210(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
211 (declare (dynamic-extent initargs))
212; (warn "CLASS ~A ARGS ~A:" class initargs)
213 (prog1
214 (if (or (not direct-superclasses-p)
215 (loop for direct-superclass in direct-superclasses
216 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
217 (call-next-method)
218 (apply #'call-next-method
219 class
220 :direct-superclasses
221 (append direct-superclasses
222 (list (find-class 'standard-description-object)))
223 initargs))
224 (initialize-description-class class)))
225
226
227(defmethod print-object ((object standard-description-object) stream)
228 (print-unreadable-object (object stream :type nil :identity t)
229 (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
230
231(defmethod print-object ((object standard-description-class) stream)
232 (print-unreadable-object (object stream :type t :identity t)
233 (princ (ignore-errors (description-print-name (find-layer object))) stream)))
234
235(defun find-description (name)
236 (find-layer (find-class (defining-description name))))
237
238
239
4867c86f 240
241
242