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