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