Move initialization of attribute object
[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 ;;; 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 happen 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 (apply #'reinitialize-instance attribute
111 (direct-attribute-properties direct-slot))
112 (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot))
113
114 (setf (slot-value description (attribute-name attribute))
115 attribute))))))))
116
117 ;;;; HACK: run this at startup till we figure things out.
118 (defun initialize-descriptions ()
119 (map nil #'initialize-description-class
120 (setf *defined-descriptions*
121 (remove-duplicates *defined-descriptions*))))
122
123 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
124 (declare (dynamic-extent initargs))
125 (prog1
126 (if (loop for direct-superclass in direct-superclasses
127 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
128 (call-next-method)
129 (apply #'call-next-method
130 class
131 :direct-superclasses
132 (append direct-superclasses
133 (list (find-class 'standard-description-object)))
134 initargs))
135 (initialize-description-class class)))
136
137
138 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
139 (declare (dynamic-extent initargs))
140 ; (warn "CLASS ~A ARGS ~A:" class initargs)
141 (prog1
142 (if (or (not direct-superclasses-p)
143 (loop for direct-superclass in direct-superclasses
144 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
145 (call-next-method)
146 (apply #'call-next-method
147 class
148 :direct-superclasses
149 (append direct-superclasses
150 (list (find-class 'standard-description-object)))
151 initargs))
152 (initialize-description-class class)))
153
154
155 (defmethod print-object ((object standard-description-object) stream)
156 (print-unreadable-object (object stream :type nil :identity t)
157 (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
158
159 (defmethod print-object ((object standard-description-class) stream)
160 (print-unreadable-object (object stream :type t :identity t)
161 (princ (ignore-errors (description-print-name (find-layer object))) stream)))
162
163 (defun find-description (name)
164 (find-layer (find-class (defining-description name))))
165
166
167
168
169
170