Add dlambda + contextl hack
[clinton/lisp-on-lines.git] / src / ucw / lol-tags.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines-ucw)
2
3;;; * Lisp on Lines YACLML tags.
4
5;;; * Utilities
6
7(defun gen-id (string)
8 `(js:gen-js-name-string :prefix ,string))
9
10;;; ** ACTION tags
11
12;;; These tags take UCW "actions" and create the appropriate HTML
13;;; tag to signal their execution.
14
15(defmacro %with-action-unique-names (&body body)
16 "These magic macros."
17 `(with-unique-names (url action-object action-id current-frame)
18 (assert (xor action action* function) nil
19 "Must supply only one of ACTION, ACTION* or FUNCTION")
20 (rebinding (id)
21 `(let* ((,current-frame (context.current-frame *context*))
22 (,action-object ,(or action*
23 `(lol-ucw:make-action
24 ,(or function
25 `(lambda ()
26 (with-call/cc ,action))))))
27 (,action-id (register-action-in-frame
28 ,current-frame
29 ,action-object))
30
31
32 (,url (compute-url ,action-object *current-component*)))
33 (declare (ignorable ,action-id ,url))
34 ,,@body))))
35
36
37(deftag-macro <lol:a (&attribute (id (gen-id "lol-action"))
38 action action* function
39 &allow-other-attributes others
40 &body body)
41 "A Simple <:A which does not require javascript."
42 (%with-action-unique-names
43 `(<:a :href (print-uri-to-string ,url)
44 :id ,id
45 ,@others
46 ,@body)))
47
48(deftag-macro <lol:form (&attribute (id (gen-id "lol-form"))
49 action action* function
50 &allow-other-attributes others
51 &body body)
52 "A Simple form which does not require javascript. "
53 (%with-action-unique-names
54 `(<:form :action (print-uri-to-string-sans-query ,url)
55 :id ,id
56 ,@others
57 (dolist (query (uri.query ,url))
58 (if (string= ,+action-parameter-name+ (car query))
59 (<:input :type "hidden" :name ,+action-parameter-name+
60 :value (cdr query)
61 :id ,action-id)
62 (<:input :type "hidden" :name (car query) :value (cdr query))))
63 ,@body)))
64
65(deftag-macro <lol:submit (&attribute (id (gen-id "lol-submit"))
66 action action* function value
67 &allow-other-attributes others
68 &body body)
69 (%with-action-unique-names
70 `(<:input :type "submit"
71 :value (or ,value ,@body)
72 :name (format nil "~A~A~A"
73 ,+action-parameter-name+
74 ,+action-compound-name-delimiter+
75 ,action-id))))
76
77;;; * CALLBACK tags
78
79;;; All these tags take some kind of input, and execute a UCW callback.
80
81(deftag-macro <lol:input (&attribute accessor reader writer
82 (id (gen-id "lol-input"))
83 &allow-other-attributes others)
84 (let ((reader (or reader accessor))
85 (writer (or writer `(lambda (v)
86 (setf ,accessor v)))))
87
88 `(<:input :value ,reader
89 :name (register-callback ,writer)
90 ,@others)))
2548f054 91
92
93(deftag-macro <lol::%select (&attribute writer accessor
94 (test '#'eql)
95 (key '#'identity)
96 name (id (js:gen-js-name-string :prefix "sel"))
97 &allow-other-attributes others
98 &body body)
99 "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
100 "You need to supply either an accessor or a writer to <ucw:select"
101 (with-unique-names (id-value v val values)
102 (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
103 `(let ((%current-select-value ,accessor)
104 (%current-select-test ,test)
105 (%current-select-key ,key)
106 (%select-table nil)
107 (,id-value ,id))
108 (declare (ignorable %current-select-value %current-select-test %current-select-key
109 %select-table ))
110 (<:select :name (register-callback
111 (flet ((get-associated-value (v)
112 (let ((v (assoc v %select-table :test #'string=)))
113 (if v
114 (cdr v)
115 (error "Unknown option value: ~S." v)))))
116 (lambda (,v) (funcall ,writer (get-associated-value ,v))))
117 :id ,name)
118 :id ,id-value
119 ,@others
120 ,@body)))))
121
122(deftag-macro <lol::%select-action (&attribute writer accessor
123 (test '#'eql)
124 (key '#'identity)
125 name (id (js:gen-js-name-string :prefix "sel"))
126 &allow-other-attributes others
127 &body body)
128 "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
129 "You need to supply either an accessor or a writer to <ucw:select"
130 (with-unique-names (id-value v val values)
131 (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
132 `(let ((%current-select-value ,accessor)
133 (%current-select-test ,test)
134 (%current-select-key ,key)
135 (%select-table nil)
136 (,id-value ,id))
137 (declare (ignorable %current-select-value %current-select-test %current-select-key
138 %select-table ))
139 (<:select :name (register-callback
140 (flet ((get-associated-value (v)
141 (let ((v (assoc v %select-table :test #'string=)))
142 (if v
143 (cdr v)
144 (error "Unknown option value: ~S." v)))))
145 (lambda (,v) (funcall ,writer (get-associated-value ,v))))
146 :id ,name)
147 :id ,id-value
148 ,@others
149 ,@body)))))
150
151(deftag-macro <lol:select (&allow-other-attributes others
152 &body body)
153 `(<lol::%select ,@others ,@body))
154
155(deftag-macro <lol::%option (&attribute value &allow-other-attributes others &body body)
156 (with-unique-names (value-id)
157 (rebinding (value)
158 `(let ((,value-id (random-string 10)))
159 (push (cons ,value-id ,value) %select-table)
160 (<:option :value ,value-id
161 ;;NB: we are applying key to both the option value being rendered,
162 ;; as well as the selected value(s).
163 ;;That was how the code worked previously, I don't know if it is desirable.
164 ;;I think the alternative would be to apply the key to ",value" that is
165 ;; the option being rendered, and remove the :key argument from find.
166
167 ;;The logical operation we are trying to accomplish is
168 ;;(mapcar #'add-selected-attribute
169 ;; (find-all %current-select-value(s)
170 ;; (list-of-collected-<lol::%option-calls)
171 ;; :key %current-select-key))
172 :selected (when (find
173 (funcall %current-select-key ,value) ;key applied to an option
174 (if nil ;%multiple
175 %current-select-value
176 (list %current-select-value))
177 :test %current-select-test
178 :key %current-select-key)
179 T)
180 ,@others ,@body)))))
181
182(deftag-macro <lol:option (&allow-other-attributes others &body body)
183 "Replacement for the standard OPTION tag, must be used with
184 <LOL:SELECT tag. Unlike \"regular\" OPTION tags the :value
185 attribute can be any lisp object (printable or not)."
186 `(<lol::%option ,@others ,@body))
4358148e 187
188
189
190
191
192
193
194
195