Add dlambda + contextl hack

[clinton/lisp-on-lines.git] / src / ucw / lol-tags.lisp

diff --git a/src/ucw/lol-tags.lisp b/src/ucw/lol-tags.lisp
index abf7982..2d09859 100644 (file)
--- a/src/ucw/lol-tags.lisp
+++ b/src/ucw/lol-tags.lisp
@@ -88,6 +88,102 @@
   `(<:input :value ,reader
            :name (register-callback ,writer)
            ,@others)))
+
+
+(deftag-macro <lol::%select (&attribute writer accessor 
+                                       (test '#'eql) 
+                                       (key '#'identity)
+                                       name (id (js:gen-js-name-string :prefix "sel"))
+                             &allow-other-attributes others
+                             &body body)
+  "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
+            "You need to supply either an accessor or a writer to <ucw:select"
+    (with-unique-names (id-value v val values)
+      (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
+        `(let ((%current-select-value ,accessor)
+               (%current-select-test ,test)
+               (%current-select-key ,key)
+               (%select-table nil)
+               (,id-value ,id))
+          (declare (ignorable %current-select-value %current-select-test %current-select-key
+                    %select-table ))
+          (<:select :name (register-callback
+                           (flet ((get-associated-value (v)
+                                    (let ((v (assoc v %select-table :test #'string=)))
+                                      (if v
+                                          (cdr v)
+                                          (error "Unknown option value: ~S." v)))))
+                            (lambda (,v) (funcall ,writer (get-associated-value ,v))))
+                           :id ,name)
+                    :id ,id-value
+                    ,@others
+                    ,@body)))))
+
+(deftag-macro <lol::%select-action (&attribute writer accessor 
+                                       (test '#'eql) 
+                                       (key '#'identity)
+                                       name (id (js:gen-js-name-string :prefix "sel"))
+                             &allow-other-attributes others
+                             &body body)
+  "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
+            "You need to supply either an accessor or a writer to <ucw:select"
+    (with-unique-names (id-value v val values)
+      (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
+        `(let ((%current-select-value ,accessor)
+               (%current-select-test ,test)
+               (%current-select-key ,key)
+               (%select-table nil)
+               (,id-value ,id))
+          (declare (ignorable %current-select-value %current-select-test %current-select-key
+                    %select-table ))
+          (<:select :name (register-callback
+                           (flet ((get-associated-value (v)
+                                    (let ((v (assoc v %select-table :test #'string=)))
+                                      (if v
+                                          (cdr v)
+                                          (error "Unknown option value: ~S." v)))))
+                            (lambda (,v) (funcall ,writer (get-associated-value ,v))))
+                           :id ,name)
+                    :id ,id-value
+                    ,@others
+                    ,@body)))))
+
+(deftag-macro <lol:select (&allow-other-attributes others
+                           &body body)
+  `(<lol::%select ,@others ,@body))
+
+(deftag-macro <lol::%option (&attribute value &allow-other-attributes others &body body)
+  (with-unique-names (value-id)
+    (rebinding (value)
+      `(let ((,value-id (random-string 10)))
+        (push (cons ,value-id ,value) %select-table)
+        (<:option :value ,value-id
+         ;;NB: we are applying key to both the option value being rendered,
+         ;; as well as the selected value(s).
+         ;;That was how the code worked previously, I don't know if it is desirable.
+         ;;I think the alternative would be to apply the key to ",value" that is
+         ;; the option being rendered, and remove the :key argument from find.
+
+         ;;The logical operation we are trying to accomplish is
+         ;;(mapcar #'add-selected-attribute
+         ;;          (find-all %current-select-value(s)
+         ;;                    (list-of-collected-<lol::%option-calls)
+         ;;                    :key %current-select-key))
+                  :selected (when (find
+                                   (funcall %current-select-key ,value) ;key applied to an option
+                                   (if nil ;%multiple
+                                       %current-select-value
+                                       (list %current-select-value))
+                                   :test %current-select-test
+                                   :key %current-select-key)
+                              T)
+         ,@others ,@body)))))
+
+(deftag-macro <lol:option (&allow-other-attributes others &body body)
+  "Replacement for the standard OPTION tag, must be used with
+  <LOL:SELECT tag. Unlike \"regular\" OPTION tags the :value
+  attribute can be any lisp object (printable or not)."
+  `(<lol::%option ,@others ,@body))