1 (in-package :lisp-on-lines
)
3 (define-layered-function display-using-description
(description object component
)
4 ; (:argument-precedence-order )
6 "Render the object in component,
7 using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
10 display-using-description
(d o c
)
11 (<:as-html
"default :" o
))
13 (defmethod find-layer-for-type (type)
17 (define-layered-function display
(component object
&rest args
)
19 "Displays OBJECT in COMPONENT."))
21 (define-layered-method display
((component t
) (object t
)
25 "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
27 (let* ((occurence (find-occurence object
))
28 (description (or (find-display-attribute
30 (setf type
(or type
(description.type occurence
))))
33 (dletf (((description.type occurence
) type
)
34 ((description.layers description
) (append `(+
36 ;;find-layer-for-type is a
37 ;; backwards compat thing
40 (description.layers description
)))
41 ((attributes description
) (or
42 (attributes description
)
43 (list-slots object
))))
44 (funcall-with-description
45 description properties
46 #'display-using-description description object component
))
47 (error "no description for ~A" object
))))
52 (defun funcall-with-description (description properties function
&rest args
)
54 (dletf* (((description.type description
) (or
55 (getf properties
:type
)
56 (description.type description
)))
58 ((description.layers description
) (append
59 (description.layers description
)
60 (getf properties
:layers
)))
61 ((description.properties description
) properties
))
63 (description.layers description
)
65 (contextl::funcall-with-special-initargs
66 (list (cons description properties
))
68 (apply function args
))))))
69 (apply function args
)))
73 (defmacro with-description
((description &rest properties
) &body body
)
74 `(funcall-with-description ,description
(if ',(cdr properties
)
80 (defmacro do-attributes
((var description
&optional
(attributes `(attributes ,description
))) &body body
)
81 (with-unique-names (att properties type
)
82 `(dolist* (,att
,attributes
)
83 (let* ((,att
(ensure-list ,att
))
84 (,properties
(rest ,att
))
85 (,type
(getf ,properties
:type
))
86 (,var
(let ((a (find-attribute ,description
(first ,att
))))
88 (apply #'make-attribute
:name
(first ,att
) :type
,type
,properties
)
89 (if a a
(make-attribute :name
(first ,att
) :slot-name
(first ,att
)))))))
90 (funcall-with-description ,var
,properties
91 #'(lambda () ,@body
))))))
93 (defmacro with-component
((component) &body body
)
94 `(let ((self ,component
))
95 (declare (ignorable self
))
96 (flet ((display* (thing &rest args
)
97 (apply #'display
,component thing args
))
98 (display-attribute (attribute obj
&optional props
)
100 (funcall-with-description
102 #'display-using-description attribute obj
,component
)
103 (display-using-description attribute obj
,component
))))
104 (declare (ignorable #'display
* #'display-attribute
))
107 (defmacro defdisplay
(&body body
)
108 (loop with in-layerp
= (eq (car body
) :in-layer
)
109 with layer
= (if in-layerp
(cadr body
) 't
)
110 for tail on
(if in-layerp
(cddr body
) body
)
111 until
(listp (car tail
))
112 collect
(car tail
) into qualifiers
114 (when (member :in-layer qualifiers
)
115 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
117 (destructuring-bind (description object
&optional component
) (car tail
)
118 (with-unique-names (d c
)
119 (let (standard-description-p)
120 `(define-layered-method
121 display-using-description
127 (setf d
(car description
))
131 (setf standard-description-p t
)
138 (setf c
(car component
))