1518392fd1e2384712a069f84873fe88b30a7594
[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-layered-class slot-definition-attribute (standard-attribute)
17 ((slot-name :initarg :slot-name
18 :accessor attribute-slot-name
19 :layered t)))
20
21 (defmethod shared-initialize :around ((object slot-definition-attribute)
22 slots &rest args)
23 (prog1 (call-next-method)
24 (unless (attribute-setter object)
25 (setf (attribute-setter object)
26 (lambda (v o)
27 (setf (slot-value o (attribute-slot-name object)) v))))))
28
29
30 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
31 (if (slot-boundp object (attribute-slot-name attribute))
32
33 (slot-value object (attribute-slot-name attribute))
34 +unbound-slot+))
35
36 (defun attribute-slot-makunbound (attribute)
37 (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
38
39 (defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
40 direct-superclasses direct-slot-specs)
41
42 (let* ((super-descriptions
43 (mapcar #'class-of
44 (delete nil (mapcar (rcurry #'find-description nil)
45 (mapcar #'class-name direct-superclasses)))))
46 (desc-class
47 (ensure-class (defining-description name)
48 :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
49 :direct-slots
50 (loop
51 :for slot in (class-slots class)
52 :collect
53 (let ((direct-spec
54 (find (slot-definition-name slot)
55 direct-slot-specs
56 :key (rcurry 'getf :name))))
57 (if direct-spec
58 (append (alexandria:remove-from-plist direct-spec
59 :initfunction
60 :initform
61 :initargs
62 :readers
63 :writers)
64 (unless
65 (getf direct-spec :attribute-class)
66 (list :attribute-class 'slot-definition-attribute))
67 (unless
68 (getf direct-spec :label)
69 (list :label (format nil
70 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
71 (list :slot-name (slot-definition-name slot)))
72 `(:name ,(slot-definition-name slot)
73 :attribute-class slot-definition-attribute
74 :slot-name ,(slot-definition-name slot)
75 :label ,(format nil
76 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
77 :into slots
78 :collect (slot-definition-name slot) :into names
79 :finally (return (cons `(:name active-attributes
80 :value ',(or attributes names))
81 slots)))
82 :metaclass 'standard-description-class)))
83 (unless (ignore-errors (find-description (class-name class)))
84 (ensure-class (defining-description (class-name class))
85 :direct-superclasses (list desc-class)
86 :metaclass 'standard-description-class))
87 (find-description name)))
88
89
90 (defclass described-class ()
91 ((direct-slot-specs :accessor class-direct-slot-specs)
92 (attributes :initarg :attributes :initform nil)))
93
94 (defmethod ensure-class-using-class :around ((class described-class) name &rest args)
95
96 (call-next-method))
97
98 (defmethod direct-slot-definition-class ((class described-class) &rest initargs)
99 (let ((slot-class (call-next-method)))
100 (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
101
102 (defclass described-class-direct-slot-definition ()
103 ())
104
105 (defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
106 (call-next-method))
107
108 (defmethod validate-superclass
109 ((class described-class)
110 (superclass standard-class))
111 t)
112
113 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
114 (declare (dynamic-extent initargs))
115 (finalize-inheritance class)
116 (ensure-description-for-class class :direct-slot-specs direct-slots
117 :direct-superclasses direct-superclasses
118 :attributes (slot-value class 'attributes)))
119
120 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
121 (declare (dynamic-extent initargs))
122 (finalize-inheritance class)
123 (ensure-description-for-class class :direct-slot-specs direct-slots
124 :direct-superclasses direct-superclasses
125 :attributes (slot-value class 'attributes)))
126
127 (defclass described-standard-class (described-class standard-class ) ())
128
129 (defmethod validate-superclass
130 ((class described-standard-class)
131 (superclass standard-class))
132 t)
133
134 (define-layered-method description-of ((object standard-object))
135 (or (ignore-errors (find-description (class-name (class-of object))))
136 (find-description 'standard-object)))
137
138
139