6d0aa5eb |
1 | (in-package :lisp-on-lines) |
2 | |
3 | (defdynamic described-object nil) |
4 | (defdynamic description nil) |
5 | |
6 | ;;backwards-compat hacks |
7 | (define-symbol-macro *object* (dynamic described-object)) |
8 | (define-symbol-macro *description* (dynamic description)) |
9 | |
10 | ;; forward compat hacks |
11 | |
12 | (defun current-description () |
13 | (dynamic description)) |
14 | |
15 | (define-layered-function description-of (thing) |
16 | (:method (thing) |
17 | (find-description 't))) |
18 | |
19 | (defun description-print-name (description) |
20 | (description-class-name (class-of description))) |
21 | |
22 | (defun description-attributes (description) |
23 | (alexandria:hash-table-values (description-class-attributes (class-of description)))) |
24 | |
25 | (defun description-current-attributes (description) |
26 | (remove-if-not |
27 | (lambda (attribute) |
28 | (and |
29 | (some #'layer-active-p |
30 | (mapcar #'find-layer |
31 | (slot-definition-layers |
32 | (attribute-effective-attribute-definition attribute)))))) |
33 | (description-attributes description))) |
34 | |
35 | (defun description-active-attributes (description) |
36 | (remove-if-not |
37 | #'attribute-active-p |
38 | (description-attributes description))) |
39 | |
40 | |
41 | |
42 | (define-layered-function description-active-descriptions (description) |
43 | (:method ((description t)) |
44 | (attribute-value (find-attribute description 'active-descriptions))) |
45 | (:method ((description attribute)) |
46 | (attribute-active-descriptions description))) |
47 | |
48 | (define-layered-function description-inactive-descriptions (description) |
49 | (:method ((description t)) |
50 | (attribute-value (find-attribute description 'inactive-descriptions))) |
51 | (:method ((description attribute)) |
52 | (attribute-inactive-descriptions description))) |
53 | |
54 | (define-layered-function attributes (description) |
55 | (:method (description) |
56 | (let* ((active-attributes |
57 | (find-attribute description 'active-attributes)) |
58 | (attributes (when active-attributes |
59 | (ignore-errors (attribute-value active-attributes))))) |
60 | (remove-if-not |
61 | (lambda (attribute) |
62 | (and attribute |
63 | (attribute-active-p attribute) |
64 | (some #'layer-active-p |
65 | (attribute-layers attribute)))) |
66 | (if attributes |
67 | (mapcar (lambda (spec) |
68 | (find-attribute |
69 | description |
70 | (if (listp spec) |
71 | (car spec) |
72 | spec))) |
73 | attributes) |
74 | (description-attributes description)))))) |
75 | |
76 | (defun funcall-with-described-object (function object description &rest args) |
77 | (setf description (or description (description-of object))) |
78 | (dynamic-let ((description description) |
79 | (object object)) |
80 | (dletf (((described-object description) object)) |
81 | (funcall-with-layer-context |
82 | (modify-layer-context (adjoin-layer description (current-layer-context)) |
83 | :activate (description-active-descriptions description) |
84 | :deactivate (description-inactive-descriptions description)) |
85 | (lambda () |
86 | (with-special-symbol-access |
87 | (contextl::funcall-with-special-initargs |
88 | (without-special-symbol-access |
89 | (loop |
90 | :for (key val) :on args :by #'cddr |
91 | :collect (list (find key (description-attributes description) |
92 | :key #'attribute-keyword) |
93 | :value val))) |
94 | (lambda () |
95 | (contextl::funcall-with-special-initargs |
96 | (without-special-symbol-access |
97 | (let ((attribute (ignore-errors (find-attribute description 'active-attributes)))) |
98 | (when attribute |
99 | (loop for spec in (attribute-value attribute) |
100 | if (listp spec) |
101 | collect (cons (or |
102 | (find-attribute description (car spec)) |
103 | (error "No attribute matching ~A" (car spec))) |
104 | (cdr spec)))))) |
105 | (lambda () |
106 | (without-special-symbol-access |
107 | (funcall function)))))))))))) |
108 | |
109 | (defmacro with-described-object ((object &optional (description `(description-of ,object))) |
110 | &body body) |
111 | `(funcall-with-described-object (lambda (),@body) ,object ,description)) |
112 | |
113 | |
114 | |
115 | |
116 | |
117 | |
118 | |
119 | |
120 | |
121 | |
122 | |
123 | |
124 | |
125 | |
126 | |
127 | |
128 | |
129 | |
130 | |
131 | |
132 | |