6d0aa5eb |
1 | |
2 | (in-package :lisp-on-lines) |
3 | |
4 | (define-layered-class attribute () |
5 | ()) |
6 | |
7 | (define-layered-class standard-attribute (simple-plist-attribute) |
8 | ((attribute-layers :accessor attribute-layers :initform nil) |
9 | (name |
10 | :layered-accessor attribute-name |
11 | :initarg :name) |
12 | (effective-attribute-definition |
13 | :initarg effective-attribute |
14 | :accessor attribute-effective-attribute-definition) |
15 | #+nil (attribute-class |
16 | :accessor attribute-class |
17 | :initarg :attribute-class |
18 | :initform 'standard-attribute) |
19 | (keyword |
20 | :layered-accessor attribute-keyword |
21 | :initarg :keyword |
22 | :initform nil |
23 | :layered t) |
24 | (activep |
25 | :layered-accessor attribute-active-p |
26 | :initarg :activep ;deprecated |
27 | :initarg :active |
28 | :initform t |
29 | :layered t |
30 | :special t |
31 | :documentation |
32 | "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") |
33 | (value |
34 | :layered-accessor attribute-value |
35 | :initarg :value |
36 | :layered t |
37 | :special t) |
38 | (function |
39 | :initarg :function |
40 | :layered-accessor attribute-function |
41 | :layered t |
42 | :special t) |
43 | (active-attributes :layered-accessor attribute-active-attributes |
44 | :initarg :attributes |
45 | :layered t |
46 | :special t) |
47 | (active-descriptions :layered-accessor attribute-active-descriptions |
48 | :initarg :activate |
49 | :initform nil |
50 | :layered t |
51 | :special t) |
52 | (inactive-descriptions :layered-accessor attribute-inactive-descriptions |
53 | :initarg :deactivate |
54 | :initform nil |
55 | :layered t |
56 | :special t) |
57 | )) |
58 | |
59 | (defmethod attribute-description ((attribute standard-attribute)) |
60 | (find-layer (attribute-description-class attribute))) |
61 | |
62 | (define-layered-function attribute-object (attribute)) |
63 | (define-layered-method attribute-active-p :around (attribute) |
64 | (let ((active? (call-next-method))) |
65 | (if (eq :when active?) |
66 | (not (null (attribute-value attribute))) |
67 | active?))) |
68 | |
69 | |
70 | (define-layered-method attribute-object ((attribute standard-attribute)) |
71 | (described-object (dynamic description))) |
72 | |
73 | (define-layered-function attribute-value-using-object (object attribute)) |
74 | (define-layered-function (setf attribute-value-using-object) (value object attribute)) |
75 | |
76 | (define-layered-method attribute-value ((attribute standard-attribute)) |
77 | (attribute-value-using-object (attribute-object attribute) attribute)) |
78 | |
79 | (define-layered-method attribute-value-using-object (object attribute) |
80 | (let ((fn (handler-case (attribute-function attribute) |
81 | (unbound-slot () nil)))) |
82 | (if fn |
83 | (funcall fn object) |
84 | (slot-value attribute 'value)))) |
85 | |
86 | (define-layered-method (setf attribute-value) (value (attribute standard-attribute)) |
87 | (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) |
88 | |
89 | (define-layered-method (setf attribute-value-using-object) (value object attribute) |
90 | (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable" |
91 | object attribute)) |
92 | |
93 | (defmethod print-object ((object standard-attribute) stream) |
94 | (print-unreadable-object (object stream :type nil :identity t) |
95 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) |