Fix missing `without-special-symbol-access' in `funcall-with-attribute-context'
[clinton/lisp-on-lines.git] / src / standard-descriptions / clos.lisp
1 (in-package :lisp-on-lines)
2
3 (defstruct unbound-slot-value (s))
4
5 (defvar +unbound-slot+ (make-unbound-slot-value))
6
7 (defmethod print-object ((object unbound-slot-value) stream)
8 (print-unreadable-object (object stream)
9 (format stream "UNBOUND")))
10
11 (define-description standard-object ()
12 ((editp :value t)
13 (class-slots :label "Slots"
14 :function (compose 'class-slots 'class-of))))
15
16 (define-description standard-object ()
17 ((editp :value t)
18 (class-slots :label "Slots"
19 :function (compose 'class-slots 'class-of)))
20 (:in-description editable))
21
22 (define-layered-class slot-definition-attribute (define-description-attribute)
23 ((slot-name :initarg :slot-name
24 :accessor attribute-slot-name
25 :layered t)))
26
27
28 (define-layered-method attribute-active-p :around ((attribute slot-definition-attribute))
29 (let ((active? (slot-value attribute 'activep)))
30 (if (and (eq :when active?)
31 (unbound-slot-value-p (attribute-value attribute)))
32 NIL
33
34 (call-next-method))))
35
36 (define-layered-method attribute-active-p
37 :in-layer #.(defining-description 'editable)
38 :around ((attribute slot-definition-attribute))
39 (let ((active? (slot-value attribute 'activep)))
40 (if (and (eq :when active?)
41 (unbound-slot-value-p (attribute-value attribute)))
42 t
43 (call-next-method))))
44
45 (defmethod shared-initialize :around ((object slot-definition-attribute)
46 slots &rest args)
47 (with-active-descriptions (editable)
48 (prog1 (call-next-method)
49 (unless (attribute-setter object)
50 (setf (attribute-setter object)
51 (lambda (v o)
52 (if (unbound-slot-value-p v)
53 (slot-makunbound o (attribute-slot-name object))
54 (setf (slot-value o (attribute-slot-name object)) v))))))))
55
56
57 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
58 (if (slot-boundp object (attribute-slot-name attribute))
59
60 (slot-value object (attribute-slot-name attribute))
61 +unbound-slot+))
62
63 (defun attribute-slot-makunbound (attribute)
64 (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
65
66 (defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
67 direct-superclasses direct-slot-specs)
68
69 (let* ((super-descriptions
70 (mapcar #'class-of
71 (delete nil (mapcar (rcurry #'find-description nil)
72 (mapcar #'class-name direct-superclasses)))))
73 (desc-class
74 (ensure-layer (defining-description name)
75 :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
76 :direct-slots
77 (loop
78 :for slot in (class-slots class)
79 :collect
80 (let ((direct-spec
81 (find (slot-definition-name slot)
82 direct-slot-specs
83 :key (rcurry 'getf :name))))
84 (if direct-spec
85 (append (alexandria:remove-from-plist direct-spec
86 :initfunction
87 :initform
88 :initargs
89 :readers
90 :writers)
91 (unless
92 (getf direct-spec :attribute-class)
93 (list :attribute-class 'slot-definition-attribute))
94 (unless
95 (getf direct-spec :label)
96 (list :label (format nil
97 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
98 (list :slot-name (slot-definition-name slot)))
99 `(:name ,(slot-definition-name slot)
100 :attribute-class slot-definition-attribute
101 :slot-name ,(slot-definition-name slot)
102 :label ,(format nil
103 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
104 :into slots
105 :collect (slot-definition-name slot) :into names
106 :finally (return (cons `(:name active-attributes
107 :value ',(or attributes names))
108 slots)))
109 :metaclass 'define-description-class)))
110 (unless (ignore-errors (find-description (class-name class)))
111 (find-layer (ensure-layer (defining-description (class-name class))
112 :direct-superclasses (list desc-class)
113 :metaclass 'define-description-class)))))
114
115
116 (defclass described-class ()
117 ((direct-slot-specs :accessor class-direct-slot-specs)
118 (attributes :initarg :attributes :initform nil)))
119
120 (defmethod ensure-class-using-class :around ((class described-class) name &rest args)
121
122 (call-next-method))
123
124 (defmethod direct-slot-definition-class ((class described-class) &rest initargs)
125 (let ((slot-class (call-next-method)))
126 (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
127
128 (defclass described-class-direct-slot-definition ()
129 ())
130
131 (defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
132 (call-next-method))
133
134 (defmethod validate-superclass
135 ((class described-class)
136 (superclass standard-class))
137 t)
138
139 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
140 (declare (dynamic-extent initargs))
141 (finalize-inheritance class)
142 (ensure-description-for-class class :direct-slot-specs direct-slots
143 :direct-superclasses direct-superclasses
144 :attributes (slot-value class 'attributes)))
145
146 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
147 (declare (dynamic-extent initargs))
148 (finalize-inheritance class)
149 (ensure-description-for-class class :direct-slot-specs direct-slots
150 :direct-superclasses direct-superclasses
151 :attributes (slot-value class 'attributes)))
152
153 (defclass described-standard-class (described-class standard-class ) ())
154
155 (defmethod validate-superclass
156 ((class described-standard-class)
157 (superclass standard-class))
158 t)
159
160 (define-layered-method description-of ((object standard-object))
161 (or (ignore-errors (find-description (class-name (class-of object))))
162 (find-description 'standard-object)))
163
164
165