1 (in-package :lisp-on-lines
)
3 (define-layered-function display-using-description
(description object component
)
5 "Render the object in component,
6 using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
9 display-using-description
(d o c
)
10 (<:as-html
"default :" o
))
12 (defmethod find-layer-for-type (type)
16 (define-layered-function display
(component object
&rest args
)
18 "Displays OBJECT in COMPONENT."))
20 (define-layered-method display
((component t
) (object t
)
24 "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
26 (let* ((occurence (find-occurence object
))
27 (description (or (find-display-attribute
29 (setf type
(or type
(description.type occurence
))))
32 (dletf (((description.type occurence
) type
)
33 ((description.layers description
) (append `(+
35 ;;find-layer-for-type is a
36 ;; backwards compat thing
39 (description.layers description
)))
40 ((attributes description
) (or
41 (attributes description
)
42 (list-slots object
))))
43 (funcall-with-description
44 description properties
45 #'display-using-description description object component
))
46 (error "no description for ~A" object
))))
49 ;;;; TODO: " should really be a funcall-with function with a small wrapper."
51 (defun funcall-with-description (description properties function
&rest args
)
53 (dletf* (((description.type description
) (or
54 (getf properties
:type
)
55 (description.type description
)))
57 ((description.layers description
) (append
58 (description.layers description
)
59 (getf properties
:layers
)))
60 ((description.properties description
) properties
))
62 (description.layers description
)
64 (funcall-with-special-initargs
65 description properties
67 (apply function args
))))))
68 (apply function args
)))
72 (defmacro with-description
((description &rest properties
) &body body
)
73 `(funcall-with-description ,description
(if ',(cdr properties
)
79 (defmacro do-attributes
((var description
&optional
(attributes `(attributes ,description
))) &body body
)
80 (with-unique-names (att properties type
)
81 `(dolist* (,att
,attributes
)
82 (let* ((,att
(ensure-list ,att
))
83 (,properties
(rest ,att
))
84 (,type
(getf ,properties
:type
))
85 (,var
(let ((a (find-attribute ,description
(first ,att
))))
87 (apply #'make-attribute
:name
(first ,att
) :type
,type
,properties
)
88 (if a a
(make-attribute :name
(first ,att
) :slot-name
(first ,att
)))))))
89 (funcall-with-description ,var
,properties
90 #'(lambda () ,@body
))))))
92 (defmacro with-component
((component) &body body
)
93 `(let ((self ,component
))
94 (declare (ignorable self
))
95 (flet ((display* (thing &rest args
)
96 (apply #'display
,component thing args
))
97 (display-attribute (attribute obj
&optional props
)
99 (funcall-with-description
101 #'display-using-description attribute obj
,component
)
102 (display-using-description attribute obj
,component
))))
103 (declare (ignorable #'display
* #'display-attribute
))
106 (defmacro defdisplay
(&body body
)
107 (loop with in-layerp
= (eq (car body
) :in-layer
)
108 with layer
= (if in-layerp
(cadr body
) 't
)
109 for tail on
(if in-layerp
(cddr body
) body
)
110 until
(listp (car tail
))
111 collect
(car tail
) into qualifiers
113 (when (member :in-layer qualifiers
)
114 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
116 (destructuring-bind (description object
&optional component
) (car tail
)
117 (with-unique-names (d c
)
118 (let (standard-description-p)
119 `(define-layered-method
120 display-using-description
126 (setf d
(car description
))
130 (setf standard-description-p t
)
137 (setf c
(car component
))