Added standard descriptions and UCW integration.
[clinton/lisp-on-lines.git] / src / ucw / lol-tags.lisp
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)))
91
92
93
94
95
96
97
98
99