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