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