1dbc902fff90a1bf6cac9982fe9c87cae4d3f064
[clinton/lisp-on-lines.git] / src / mao / description-class.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; SLOT-DEFINITION META-OBJECTS
4 (define-layered-class direct-attribute-slot-definition-class
5 (special-layered-direct-slot-definition
6 contextl::singleton-direct-slot-definition)
7 ((attribuite-properties
8 :accessor slot-definition-attribute-properties
9 :documentation "Holds the initargs passed to the slotd")))
10
11 (defmethod initialize-instance
12 :after ((slotd direct-attribute-slot-definition-class)
13 &rest initargs)
14 (setf (slot-definition-attribute-properties slotd) initargs))
15
16 (defmethod reinitialize-instance
17 :after ((slotd direct-attribute-slot-definition-class)
18 &rest initargs)
19 (setf (slot-definition-attribute-properties slotd) initargs))
20
21 (define-layered-class effective-attribute-slot-definition-class
22 (special-layered-effective-slot-definition)
23 ((direct-slots :accessor slot-definition-direct-slots)
24 (attribute-object
25 :accessor slot-definition-attribute-object)))
26
27 ;;;; DESCRIPTION-ACCESS-CLASS, the PARTIAL-CLASS defining class for DESCRIPTIONs
28 (define-layered-class description-access-class
29 (standard-layer-class contextl::special-layered-access-class)
30 ((defined-in-descriptions :initarg :in-description)
31 (class-active-attributes-definition :initarg :attributes)
32 (mixin-class-p :initarg :mixinp)
33 (description-name :initarg original-name
34 :initform nil
35 :reader description-original-name)))
36
37 (defmethod direct-slot-definition-class
38 ((class description-access-class) &key &allow-other-keys)
39 (find-class 'direct-attribute-slot-definition-class))
40
41 (defmethod effective-slot-definition-class
42 ((class description-access-class) &key &allow-other-keys)
43 (find-class 'effective-attribute-slot-definition-class))
44
45
46 ;;;;STANDARD-DESCRIPTION
47 (defclass standard-description-class (description-access-class layered-class)
48 ((attributes :accessor description-class-attributes :initform (make-hash-table :test #'eq)))
49 (:default-initargs :defining-metaclass 'description-access-class))
50
51 (defclass standard-description-object
52 (standard-layer-object)
53 ((described-object :accessor described-object
54 :special t
55 :function 'identity)
56 (ACTIVE-ATTRIBUTES :LABEL "Attributes" :VALUE NIL :ACTIVEP NIL
57 :KEYWORD :ATTRIBUTES)
58 (ACTIVE-DESCRIPTIONS :LABEL "Active Descriptions" :VALUE NIL
59 :ACTIVEP NIL :KEYWORD :ACTIVATE)
60 (INACTIVE-DESCRIPTIONS :LABEL "Inactive Descriptions" :VALUE NIL
61 :ACTIVEP NIL :KEYWORD :DEACTIVATE))
62 (:METACLASS description-access-class)
63 (ORIGINAL-NAME . STANDARD-DESCRIPTION-OBJECT))
64
65
66 (defgeneric find-attribute (description-designator attribute-name &optional errorp)
67 (:method ((description standard-description-class) attribute-name &optional (errorp t))
68 (or (gethash attribute-name (description-class-attributes description))
69 (when errorp
70 (when errorp (error "No attribute named ~A found in class ~A" attribute-name description)))))
71 (:method ((description standard-description-object) attribute-name &optional (errorp t))
72 (find-attribute (class-of description) attribute-name errorp))
73 (:method ((description symbol) attribute-name &optional (errorp t))
74 (find-attribute (find-description description) attribute-name errorp)))
75
76 (defgeneric (setf find-attribute) (value description attribute-name)
77 (:method (value (description standard-description-class) attribute-name)
78 (setf (gethash attribute-name (description-class-attributes description)) value)))
79
80 (defmethod description-class-attribute-class (description)
81 'standard-attribute)
82
83 (defmethod initialize-slot-definition-attribute
84 (class (slotd effective-attribute-slot-definition-class)
85 name direct-slot-definitions)
86 (let ((tbl (make-hash-table)))
87 (loop for ds in direct-slot-definitions
88 :when (typep ds 'direct-attribute-slot-definition-class)
89 :do (setf (gethash (slot-definition-layer ds) tbl)
90 (append (gethash (slot-definition-layer ds) tbl '())
91 (slot-definition-attribute-properties ds))))
92
93 (let* ((attribute-class (or (getf (gethash t tbl) :attribute-class)
94 (description-class-attribute-class class)))
95 (attribute (apply #'make-instance attribute-class :name name 'description-class class (gethash t tbl))))
96 (maphash (lambda (layer properties)
97 (pushnew layer (attribute-layers attribute))
98 (apply #'initialize-attribute-for-description class attribute layer properties))
99 tbl)
100 (setf (slot-definition-attribute-object slotd) attribute)
101 (setf (find-attribute class name) attribute))))
102
103 (defmethod compute-effective-slot-definition
104 ((class standard-description-class) name direct-slot-definitions)
105 (declare (ignore name))
106 (let ((slotd (call-next-method)))
107 (setf (slot-definition-direct-slots slotd) direct-slot-definitions)
108 (when (class-finalized-p class)
109 (initialize-slot-definition-attribute class slotd name direct-slot-definitions))
110 slotd))
111
112 (defmethod finalize-inheritance :after ((class standard-description-class))
113 (dolist (slotd (compute-slots class))
114 (initialize-slot-definition-attribute class slotd (slot-definition-name slotd) (slot-definition-direct-slots slotd))))
115
116 (defmethod validate-superclass
117 ((class standard-description-class)
118 (superclass standard-class))
119 t)
120
121 (defmacro defdescription (name &optional superdescriptions &body options)
122 (destructuring-bind (&optional slots &rest options) options
123 `(let ((description-name ',name))
124 (declare (special description-name))
125 (deflayer ,(defining-description name) ,(mapcar #'defining-description superdescriptions)
126 ,(if slots slots '())
127 ,@options
128 ,@(unless (assoc :metaclass options)
129 '((:metaclass standard-description-class)))
130 ,@(let ((in-description (assoc :in-description options)))
131 (when in-description
132 `((:in-layer . ,(defining-description (cadr in-description))))))
133
134 (original-name . ,name)))))
135
136
137
138 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
139 (declare (dynamic-extent initargs))
140 (prog1
141 (if (loop for direct-superclass in direct-superclasses
142 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
143 (call-next-method)
144 (apply #'call-next-method
145 class
146 :direct-superclasses
147 (append direct-superclasses
148 (list (find-class 'standard-description-object)))
149 initargs))))
150
151 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
152 (declare (dynamic-extent initargs))
153 ; (warn "CLASS ~A ARGS ~A:" class initargs)
154 (prog1
155 (if (or (not direct-superclasses-p)
156 (loop for direct-superclass in direct-superclasses
157 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
158 (call-next-method)
159 (apply #'call-next-method
160 class
161 :direct-superclasses
162 (append direct-superclasses
163 (list (find-class 'standard-description-object)))
164 initargs))))
165
166 (defun find-description (name &optional (errorp t))
167 (find-layer (defining-description name) errorp))
168
169 (defun description-class-name (description-class)
170 (ignore-errors (description-original-name (first (class-direct-superclasses description-class)))))
171
172 (defmethod print-object ((class standard-description-class) stream)
173 (print-unreadable-object (class stream :type nil :identity t)
174 (format stream "DESCRIPTION-CLASS ~A" (description-class-name class))))
175
176 (defun description-name (description)
177 (description-class-name (class-of description)))
178
179 (defmethod print-object ((object standard-description-object) stream)
180 (print-unreadable-object (object stream :type nil :identity t)
181 (format stream "DESCRIPTION ~A" (description-name object))))