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 | |