Moved description details out of display.
[clinton/lisp-on-lines.git] / src / description.lisp
1 (in-package :lisp-on-lines)
2
3 (defvar *object* nil)
4 (defvar *description*)
5
6 (define-layered-function description-of (thing)
7 (:method (thing)
8 (find-description 't)))
9
10 (defun description-print-name (description)
11 (description-class-name (class-of description)))
12
13 (defun description-attributes (description)
14 (description-class-attributes (class-of description)))
15
16 (defun description-current-attributes (description)
17 (remove-if-not
18 (lambda (attribute)
19 (and
20 (some #'layer-active-p
21 (mapcar #'find-layer
22 (slot-definition-layers
23 (attribute-effective-attribute-definition attribute))))))
24 (description-attributes description)))
25
26 (defun description-active-attributes (description)
27 (remove-if-not
28 #'attribute-active-p
29 (description-attributes description)))
30
31 (defun find-attribute (description attribute-name)
32 (find attribute-name (description-attributes description)
33 :key #'attribute-name))
34
35 (define-layered-function description-active-descriptions (description)
36 (:method ((description standard-description-object))
37 (attribute-value (find-attribute description 'active-descriptions)))
38 (:method ((description attribute))
39 (attribute-active-descriptions description)))
40
41 (define-layered-function description-inactive-descriptions (description)
42 (:method ((description standard-description-object))
43 (attribute-value (find-attribute description 'inactive-descriptions)))
44 (:method ((description attribute))
45 (attribute-inactive-descriptions description)))
46
47 (define-layered-function attributes (description)
48 (:method (description)
49 (let* ((active-attributes
50 (find-attribute description 'active-attributes))
51 (attributes (when active-attributes
52 (ignore-errors (attribute-value active-attributes)))))
53 (if attributes
54 (mapcar (lambda (spec)
55 (find-attribute
56 description
57 (if (listp spec)
58 (car spec)
59 spec)))
60 attributes)
61 (remove-if-not
62 (lambda (attribute)
63 (and (attribute-active-p attribute)
64 (some #'layer-active-p
65 (mapcar #'find-layer
66 (slot-definition-layers
67 (attribute-effective-attribute-definition attribute))))))
68 (description-attributes description))))))
69
70
71 (defun funcall-with-described-object (function object description &rest args)
72 (setf description (or description (description-of object)))
73 (let ((*description* description)
74 (*object* object))
75 (dletf (((described-object *description*) object))
76 (funcall-with-layer-context
77 (modify-layer-context
78 (if (standard-description-p *description*)
79 (adjoin-layer *description* (current-layer-context))
80 (current-layer-context))
81 :activate (description-active-descriptions *description*)
82 :deactivate (description-inactive-descriptions *description*))
83 (lambda () (contextl::funcall-with-special-initargs
84 (loop
85 :for (key val) :on args :by #'cddr
86 :collect (list (find key (description-attributes *description*)
87 :key #'attribute-keyword)
88 :value val))
89 (lambda ()
90 (contextl::funcall-with-special-initargs
91 (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))
92 (when attribute
93 (loop for spec in (attribute-value attribute)
94 if (listp spec)
95 collect (cons (or
96 (find-attribute *description* (car spec))
97 (error "No attribute matching ~A" (car spec)))
98 (cdr spec)))))
99 function))))))))
100
101
102 (defmacro with-described-object ((object description &rest args)
103 &body body)
104 `(funcall-with-described-object
105 (lambda () ,@body)
106 ,object
107 ,description
108 ,@args))
109
110 (defmacro define-description (name &optional superdescriptions &body options)
111 (let ((description-name (defining-description name)))
112 (destructuring-bind (&optional slots &rest options) options
113 (let ((description-layers (cdr (assoc :in-description options))))
114 (if description-layers
115 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
116 ,@(loop
117 :for layer
118 :in description-layers
119 :collect `(define-description
120 ,name ,superdescriptions ,slots
121 ,@(acons
122 :in-layer (defining-description layer)
123 (remove :in-description options :key #'car)))))
124 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
125 ; `(progn
126 (defclass ,description-name
127 ,(append (mapcar #'defining-description
128 superdescriptions)
129 (unless (or (eq t name)
130 (assoc :mixinp options))
131 (list (defining-description t))))
132 ,(if slots slots '())
133 ,@options
134 ,@(unless (assoc :metaclass options)
135 '((:metaclass standard-description-class))))
136 (initialize-descriptions)
137 (find-description ',name)))))))
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157