1 (in-package :lisp-on-lines
)
3 (define-layered-function display-using-description
(description object component
)
4 (:method-combination wrapping-standard
)
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 (defun make-display-function (component object
15 &key type
(line #'line-in
)
17 "returns a function that expects a 3 argument function as its argument
19 The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
22 (let* ((description (find-occurence object
)))
25 (dletf (((description-type description
) type
)
26 ((attributes description
) (or
27 (attributes description
)
28 (list-attributes description
))))
29 ;; apply the default line to the description
30 (funcall-with-description
33 ;; apply the passed in arguments and call display-using-description
35 (funcall-with-description
38 function description object component
))))
39 (error "no description for ~A" object
)))))
41 (define-layered-function display
(component object
&rest args
)
43 "Displays OBJECT in COMPONENT."))
45 (define-layered-method display
((component t
) (object t
)
47 " The default display dispatch method
49 DISPLAY takes two required arguments,
50 COMPONENT : The component to display FROM (not neccesarily 'in')
51 OBJECT : The 'thing' we want to display... in this case it's the component
53 DISPLAY also takes keywords arguments which modify the DESCRIPTION,
54 that is to say the parameters that come together to create the output.
56 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
57 (funcall (apply 'make-display-function component object properties
)
58 'display-using-description
))
63 (defun funcall-with-description (description properties function
&rest args
)
66 (dletf* (((description-type description
) (or
67 (getf properties
:type
)
68 (description-type description
)))
70 ((description-layers description
) (append
71 (description-layers description
)
72 (getf properties
:layers
)))
73 ((description-properties description
) (append (description-properties description
) properties
)))
75 (description-layers description
)
77 (contextl::funcall-with-special-initargs
78 (list (cons description properties
))
80 (apply function args
))))))
81 (apply function args
)))
83 (defmacro with-description
((description &rest properties
) &body body
)
84 `(funcall-with-description ,description
(if ',(cdr properties
)
90 (define-layered-function find-do-attributes
(desc))
92 (define-layered-method find-do-attributes
((description description
))
96 :in
(attributes description
)
97 :collect
(let ((default (find (car (ensure-list att
))
98 (default-attributes description
)
102 (defmacro do-attributes
((var description
&optional
(attributes `(find-do-attributes ,description
))) &body body
)
103 (with-unique-names (att properties type
)
104 `(dolist* (,att
,attributes
)
105 (let* ((,att
(ensure-list ,att
))
106 (,properties
(rest ,att
))
107 (,type
(getf ,properties
:type
))
108 (,var
(let ((a (find-attribute ,description
(first ,att
))))
110 (apply #'make-attribute
:name
(first ,att
) :type
,type
,properties
)
111 (if a a
(make-attribute :name
(first ,att
) :slot-name
(first ,att
)))))))
112 (funcall-with-description ,var
,properties
116 (defmacro with-component
((component) &body body
)
117 `(let ((self ,component
))
118 (declare (ignorable self
))
119 (flet ((display* (thing &rest args
)
120 (apply #'display
,component thing args
))
121 (display-attribute (attribute obj
&rest
124 (funcall-with-description
126 #'display-using-description attribute obj
,component
)
127 (display-using-description attribute obj
,component
))))
128 (declare (ignorable #'display
* #'display-attribute
))
131 (defmacro defdisplay
(&body body
)
132 (loop with in-layerp
= (eq (car body
) :in-layer
)
133 with layer
= (if in-layerp
(cadr body
) 't
)
134 for tail on
(if in-layerp
(cddr body
) body
)
135 until
(listp (car tail
))
136 collect
(car tail
) into qualifiers
138 (when (member :in-layer qualifiers
)
139 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
141 (destructuring-bind (description &optional object component
) (car tail
)
142 (with-unique-names (d c
)
143 (let (standard-description-p)
144 `(define-layered-method
145 display-using-description
150 (setf object description
)
155 (setf d
(car description
))
159 (setf standard-description-p t
)
166 (setf c
(car component
))