| 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 | (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)) |
| 187 | |
| 188 | |
| 189 | |
| 190 | |
| 191 | |
| 192 | |
| 193 | |
| 194 | |
| 195 | |