simplified slot access somewhat. layered slots still a little screwy.
[clinton/lisp-on-lines.git] / src / description-class.lisp
... / ...
CommitLineData
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;;; HACK:
8;;; Since i'm not using deflayer, ensure-layer etc,
9;;; There are a few places where contextl gets confused
10;;; trying to locate my description layers.
11
12;;; TODO: investigate switching to deflayer!
13
14(defun contextl::prepare-layer (layer)
15 (if (symbolp layer)
16 (if (eq (symbol-package layer)
17 (find-package :description-definers))
18 layer
19 (contextl::defining-layer layer))
20
21 layer))
22
23(defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
24 (if (eq (symbol-package layer)
25 (find-package :description-definers))
26 (find-class layer)
27 (call-next-method)))
28
29;;; #+HACK
30;;; I'm having some 'issues' with
31;;; compiled code and my initialization.
32;;; So this hack initializes the world.
33(eval-when (:compile-toplevel :load-toplevel :execute)
34 (defparameter *defined-descriptions* nil))
35
36(defclass description-access-class (standard-layer-class contextl::special-layered-access-class )
37 ((defined-in-descriptions :initarg :in-description)
38 (mixin-class-p :initarg :mixinp)))
39
40(defmethod direct-slot-definition-class
41 ((class description-access-class) &key &allow-other-keys)
42 (find-class 'direct-attribute-definition-class))
43
44(defmethod effective-slot-definition-class
45 ((class description-access-class) &key &allow-other-keys)
46 (find-class 'effective-attribute-definition-class))
47
48(defmethod compute-effective-slot-definition
49 ((class description-access-class) name direct-slot-definitions)
50 (declare (ignore name))
51 (let ((attribute (call-next-method)))
52 (setf (attribute-direct-attributes attribute) direct-slot-definitions)
53 (setf (attribute-object-initargs attribute)
54 ;; This plist will be used to init the attribute object
55 ;; Once the description itself is properly initiated.
56 (list :name name
57 'effective-attribute attribute
58 'description-class class))
59 attribute))
60
61
62(defclass standard-description-class (description-access-class layered-class)
63 ()
64 (:default-initargs :defining-metaclass 'description-access-class))
65
66(defmethod validate-superclass
67 ((class standard-description-class)
68 (superclass standard-class))
69 t)
70
71(defclass standard-description-object (standard-layer-object) ())
72
73(defun description-class-name (description-class)
74 (read-from-string (symbol-name (class-name description-class))))
75
76(defun initialize-description-class (class)
77
78;;; HACK: initialization does not happ en properly
79;;; when compiling and loading or something like that.
80;;; Obviously i'm not sure why.
81;;; So we're going to explicitly initialize things.
82;;; For now. --drewc
83
84 (pushnew class *defined-descriptions*)
85
86;;; ENDHACK.
87
88 (let* ((description (find-layer class))
89 (attribute-objects
90 (mapcar
91 (lambda (slot)
92 (setf (attribute-object slot)
93 (apply #'make-instance
94 'standard-attribute
95 (attribute-object-initargs slot))))
96 (class-slots (class-of description))))
97 (defining-classes (partial-class-defining-classes (class-of description))))
98
99 (loop
100 :for (layer class)
101 :on defining-classes :by #'cddr
102 :do (funcall-with-layer-context
103 (adjoin-layer (find-layer layer) (current-layer-context))
104 (lambda ()
105 (loop :for direct-slot :in (class-direct-slots class)
106 :do (let ((attribute
107 (find (slot-definition-name direct-slot)
108 attribute-objects
109 :key #'attribute-name)))
110 (dprint "Re-initing")
111 (apply #'reinitialize-instance attribute
112 (print (direct-attribute-properties direct-slot)))
113 (when (not (eq (find-class (attribute-class attribute))
114 (class-of attribute)))
115
116 (apply #'change-class attribute (attribute-class attribute)
117 (direct-attribute-properties direct-slot)))
118
119
120 (setf (slot-value description (attribute-name attribute))
121 attribute))))))))
122
123;;;; HACK: run this at startup till we figure things out.
124(defun initialize-descriptions ()
125 (map nil #'initialize-description-class
126 (setf *defined-descriptions*
127 (remove-duplicates *defined-descriptions*))))
128
129(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
130 (declare (dynamic-extent initargs))
131 (prog1
132 (if (loop for direct-superclass in direct-superclasses
133 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
134 (call-next-method)
135 (apply #'call-next-method
136 class
137 :direct-superclasses
138 (append direct-superclasses
139 (list (find-class 'standard-description-object)))
140 initargs))
141 (initialize-description-class class)))
142
143
144(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
145 (declare (dynamic-extent initargs))
146; (warn "CLASS ~A ARGS ~A:" class initargs)
147 (prog1
148 (if (or (not direct-superclasses-p)
149 (loop for direct-superclass in direct-superclasses
150 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
151 (call-next-method)
152 (apply #'call-next-method
153 class
154 :direct-superclasses
155 (append direct-superclasses
156 (list (find-class 'standard-description-object)))
157 initargs))
158 (initialize-description-class class)))
159
160
161(defmethod print-object ((object standard-description-object) stream)
162 (print-unreadable-object (object stream :type nil :identity t)
163 (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
164
165(defmethod print-object ((object standard-description-class) stream)
166 (print-unreadable-object (object stream :type t :identity t)
167 (princ (ignore-errors (description-print-name (find-layer object))) stream)))
168
169(defun find-description (name)
170 (find-layer (find-class (defining-description name))))
171
172
173
174
175
176