remove unused comment... this is why we don't comment.
[clinton/lisp-on-lines.git] / src / defdisplay.lisp
... / ...
CommitLineData
1(in-package :lisp-on-lines)
2
3(define-layered-function display-using-description (description object component)
4 (:method-combination wrapping-standard)
5 (:documentation
6 "Render the object in component,
7 using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
8
9(define-layered-method
10 display-using-description (d o c)
11 (<:as-html "default :" o))
12
13(defun make-display-function (component object
14 &rest properties
15 &key type (line #'line-in)
16 &allow-other-keys)
17 "returns a function that expects a 3 argument function as its argument
18
19The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
20
21 (lambda (function)
22 (let* ((description (find-occurence object)))
23
24 (if description
25 (dletf (((description.type description) type)
26 ((attributes description) (or
27 (attributes description)
28 (list-slots object))))
29 ;; apply the default line to the description
30 (funcall-with-description
31 description
32 (funcall line object)
33 ;; apply the passed in arguments and call display-using-description
34 #'(lambda ()
35 (funcall-with-description
36 description
37 properties
38 function description object component))))
39 (error "no description for ~A" object)))))
40
41(define-layered-function display (component object &rest args)
42 (:documentation
43 "Displays OBJECT in COMPONENT."))
44
45(define-layered-method display ((component t) (object t)
46 &rest properties
47 &key type (line #'line-in)
48 &allow-other-keys)
49 " The default display dispatch method
50
51 DISPLAY takes two required arguments,
52 COMPONENT : The component to display FROM (not neccesarily 'in')
53 OBJECT : The 'thing' we want to display... in this case it's the component
54
55 DISPLAY also takes keywords arguments which modify the DESCRIPTION,
56 that is to say the parameters that come together to create the output.
57
58The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
59
60 (let* ((description (find-occurence object)))
61
62 (if description
63 (dletf (((description.type description) type)
64 ((attributes description) (or
65 (attributes description)
66 (list-slots object))))
67 ;; apply the default line to the description
68 (funcall-with-description
69 description
70 (funcall line object)
71 ;; apply the passed in arguments and call display-using-description
72 #'(lambda ()
73 (funcall-with-description
74 description
75 properties
76 #'display-using-description description object component))))
77 (error "no description for ~A" object))))
78
79;;;;; Macros
80
81
82(defun funcall-with-description (description properties function &rest args)
83
84 (if description
85 (dletf* (((description.type description) (or
86 (getf properties :type)
87 (description.type description)))
88
89 ((description.layers description) (append
90 (description.layers description)
91 (getf properties :layers)))
92 ((description.properties description) (append (description.properties description) properties)))
93 (funcall-with-layers
94 (description.layers description)
95 #'(lambda ()
96 (contextl::funcall-with-special-initargs
97 (list (cons description properties))
98 #'(lambda ()
99 (apply function args))))))
100 (apply function args)))
101
102(defmacro with-description ((description &rest properties) &body body)
103 `(funcall-with-description ,description (if ',(cdr properties)
104 (list ,@properties)
105 ,(car properties))
106 #'(lambda ()
107 ,@body)))
108
109(define-layered-function find-do-attributes (desc))
110
111(define-layered-method find-do-attributes ((description description))
112
113 (loop
114 :for att
115 :in (attributes description)
116 :collect (let ((default (find (car (ensure-list att))
117 (default-attributes description)
118 :key #'car)))
119 (or default att))))
120
121(defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
122 (with-unique-names (att properties type)
123 `(dolist* (,att ,attributes)
124 (let* ((,att (ensure-list ,att))
125 (,properties (rest ,att))
126 (,type (getf ,properties :type))
127 (,var (let ((a (find-attribute ,description (first ,att))))
128 (if ,type
129 (apply #'make-attribute :name (first ,att) :type ,type ,properties)
130 (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
131 (funcall-with-description ,var ,properties
132 #'(lambda ()
133 ,@body))))))
134
135(defmacro with-component ((component) &body body)
136 `(let ((self ,component))
137 (declare (ignorable self))
138 (flet ((display* (thing &rest args)
139 (apply #'display ,component thing args))
140 (display-attribute (attribute obj &optional props)
141 (if props
142 (funcall-with-description
143 attribute props
144 #'display-using-description attribute obj ,component)
145 (display-using-description attribute obj ,component))))
146 (declare (ignorable #'display* #'display-attribute))
147 ,@body)))
148
149(defmacro defdisplay (&body body)
150 (loop with in-layerp = (eq (car body) :in-layer)
151 with layer = (if in-layerp (cadr body) 't)
152 for tail on (if in-layerp (cddr body) body)
153 until (listp (car tail))
154 collect (car tail) into qualifiers
155 finally
156 (when (member :in-layer qualifiers)
157 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
158 (return
159 (destructuring-bind (description &optional object component) (car tail)
160 (with-unique-names (d c)
161 (let (standard-description-p)
162 `(define-layered-method
163 display-using-description
164 :in-layer ,layer
165 ,@qualifiers
166
167 ,@(unless object
168 (setf object description)
169 (setf description d)
170 nil)
171 (,(cond
172 ((listp description)
173 (setf d (car description))
174 description)
175 (t
176 (setf d description)
177 (setf standard-description-p t)
178 `(,d description)))
179 ,object
180 ,(cond
181 ((null component)
182 `(,c component))
183 ((listp component)
184 (setf c (car component))
185 component)
186 (t
187 (setf c component)
188 `(,c component))))
189 (with-component (,c)
190 ,@(cdr tail)))))))))
191
192