removed warning which caused error
[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 (:documentation
5 "Render the object in component,
6 using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
7
8 (define-layered-method
9 display-using-description (d o c)
10 (<:as-html "default :" o))
11
12 (defmethod find-layer-for-type (type)
13 type)
14
15
16 (define-layered-function display (component object &rest args)
17 (:documentation
18 "Displays OBJECT in COMPONENT."))
19
20 (define-layered-method display ((component t) (object t)
21 &rest properties
22 &key type
23 &allow-other-keys)
24 "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
25
26 (let* ((occurence (find-occurence object))
27 (description (or (find-display-attribute
28 occurence
29 (setf type (or type (description.type occurence))))
30 occurence)))
31 (if description
32 (dletf (((description.type occurence) type)
33 ((description.layers description) (append `(+
34
35 ;;find-layer-for-type is a
36 ;; backwards compat thing
37 ,(find-layer-for-type
38 type))
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))))
47
48 ;;;;; Macros
49 ;;;; TODO: " should really be a funcall-with function with a small wrapper."
50
51 (defun funcall-with-description (description properties function &rest args)
52 (if description
53 (dletf* (((description.type description) (or
54 (getf properties :type)
55 (description.type description)))
56
57 ((description.layers description) (append
58 (description.layers description)
59 (getf properties :layers)))
60 ((description.properties description) properties))
61 (funcall-with-layers
62 (description.layers description)
63 #'(lambda ()
64 (funcall-with-special-initargs
65 description properties
66 #'(lambda ()
67 (apply function args))))))
68 (apply function args)))
69
70
71
72 (defmacro with-description ((description &rest properties) &body body)
73 `(funcall-with-description ,description (if ',(cdr properties)
74 (list ,@properties)
75 ,(car properties))
76 #'(lambda ()
77 ,@body)))
78
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))))
86 (if ,type
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))))))
91
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)
98 (if props
99 (funcall-with-description
100 attribute props
101 #'display-using-description attribute obj ,component)
102 (display-using-description attribute obj ,component))))
103 (declare (ignorable #'display* #'display-attribute))
104 ,@body)))
105
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
112 finally
113 (when (member :in-layer qualifiers)
114 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
115 (return
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
121 :in-layer ,layer
122 ,@qualifiers
123
124 (,(cond
125 ((listp description)
126 (setf d (car description))
127 description)
128 (t
129 (setf d description)
130 (setf standard-description-p t)
131 `(,d description)))
132 ,object
133 ,(cond
134 ((null component)
135 `(,c component))
136 ((listp component)
137 (setf c (car component))
138 component)
139 (t
140 (setf c component)
141 `(,c component))))
142 (with-component (,c)
143 ,@(cdr tail)))))))))
144
145