From: drewc <drewc@tech.coop>
Date: Thu, 28 Aug 2008 20:18:21 +0000 (-0700)
Subject: Changes from maxclaims branch (git).
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/2548f0540da69973512f1827b2bfd2360470bb27

Changes from maxclaims branch (git).

darcs-hash:20080828201821-39164-f2479c766c4bd3022216029009644ba44f773686.gz
---

diff --git a/src/description.lisp b/src/description.lisp
index bb1f88a..d373ace 100644
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -51,21 +51,22 @@
 	    (find-attribute description 'active-attributes))
 	   (attributes (when active-attributes
 			 (ignore-errors (attribute-value active-attributes)))))
-      (if attributes
-	  (mapcar (lambda (spec)		    
-		    (find-attribute 
-		     description
-		     (if (listp spec)
-			 (car spec)
-			 spec)))
-		  attributes)
-	  (remove-if-not 
-	   (lambda (attribute)
-	     (and (attribute-active-p attribute)		     
-		  (some #'layer-active-p 
-			(mapcar #'find-layer 
-				(slot-definition-layers 
-				 (attribute-effective-attribute-definition attribute))))))
+      (remove-if-not 
+       (lambda (attribute)
+	 (and attribute
+	      (attribute-active-p attribute)		     
+	      (some #'layer-active-p 
+		    (mapcar #'find-layer 
+			    (slot-definition-layers 
+			     (attribute-effective-attribute-definition attribute))))))
+       (if attributes
+	   (mapcar (lambda (spec)		    
+		     (find-attribute 
+		      description
+		      (if (listp spec)
+			  (car spec)
+			  spec)))
+		   attributes)
 	   (description-attributes description))))))
 	  
 
diff --git a/src/packages.lisp b/src/packages.lisp
index 44a6977..234a7be 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -17,6 +17,7 @@
    #:insert-into   
    #:select-objects
    #:select-only-n-objects
+   #:insert-object
    
 ;; Descriptions
    #:find-description
@@ -28,6 +29,7 @@
    #:with-active-descriptions
    #:with-inactive-descriptions
 
+
    ;; Displays
    #:define-display
    #:display
@@ -39,15 +41,27 @@
    #:find-attribute
    #:attribute
    #:attributes
+   #:attribute-object
    #:attribute-label
+   #:label
    #:attribute-function
    #:attribute-value
+   #:display-attribute-value
    #:active-attributes
-
+   #:attribute-delimiter
+   #:standard-attribute
    ;; Standard Library
+   
+   ;; editing
    #:editable
+   #:attribute-editor
    #:string-attribute-editor
    #:number-attribute-editor
-   #:password-attribute-editor))
+   #:password-attribute-editor
+   #:password
+
+   ;; html
+   #:display-html-attribute-editor
+   #:make-attribute-value-writer))
 
 
diff --git a/src/rofl.lisp b/src/rofl.lisp
index eb212fa..d26843f 100644
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -19,6 +19,9 @@
 
 
 ;;;; now the rofl code itself
+
+(defvar *row-reader* 'symbol-plist-row-reader)
+
 (defun %query (query)
   (cl-postgres:exec-query *database* (sql-compile query) 'symbol-plist-row-reader))
 
diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index f9e661c..1518392 100644
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -33,50 +33,98 @@
       (slot-value object (attribute-slot-name attribute))
       +unbound-slot+))
 
-(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
-  (let ((desc-class 
-	 (ensure-class (defining-description name) 
-		:direct-superclasses (list (class-of (find-description 'standard-object)))
-		:direct-slots (loop :for slot in (class-slots class)
-				 :collect `(:name ,(slot-definition-name slot) 
-					    :attribute-class slot-definition-attribute
-					    :slot-name ,(slot-definition-name slot)
-					    :label ,(format nil 
-							    "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))
-				 :into slots
+(defun attribute-slot-makunbound (attribute)
+  (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
+
+(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))) 
+				     direct-superclasses direct-slot-specs)
+
+  (let* ((super-descriptions
+	  (mapcar #'class-of 
+			      (delete nil (mapcar (rcurry #'find-description nil) 
+						  (mapcar #'class-name direct-superclasses)))))
+	 (desc-class 
+	  (ensure-class (defining-description name) 
+		:direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
+		:direct-slots 
+		(loop 
+		   :for slot in (class-slots class)
+		   :collect 
+		   (let ((direct-spec 
+			  (find (slot-definition-name slot) 
+				direct-slot-specs
+				:key (rcurry 'getf :name))))
+		     (if direct-spec 
+			 (append (alexandria:remove-from-plist direct-spec 
+							       :initfunction
+							       :initform
+							       :initargs
+							       :readers
+							       :writers)
+				 (unless 
+				     (getf direct-spec :attribute-class)
+				   (list :attribute-class 'slot-definition-attribute))
+				 (unless 
+				     (getf direct-spec :label)
+				   (list :label (format nil 
+							"~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
+				 (list :slot-name (slot-definition-name slot)))
+			 `(:name ,(slot-definition-name slot) 
+				 :attribute-class slot-definition-attribute
+				 :slot-name ,(slot-definition-name slot)
+				 :label ,(format nil 
+						 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
+		   :into slots
 				 :collect (slot-definition-name slot) :into names
 				 :finally (return (cons `(:name active-attributes
-							  :value ',names)
+							  :value ',(or attributes names))
 							slots)))	
-		:metaclass 'standard-description-class)))
-    
+		:metaclass 'standard-description-class)))    
     (unless (ignore-errors (find-description (class-name class)))
       (ensure-class (defining-description (class-name class))
 		    :direct-superclasses (list desc-class)
-			:metaclass 'standard-description-class))
-  (find-description name)))
+		    :metaclass 'standard-description-class))
+    (find-description name)))
 
 
 (defclass described-class ()
+  ((direct-slot-specs :accessor class-direct-slot-specs)
+   (attributes :initarg :attributes :initform nil)))
+
+(defmethod ensure-class-using-class :around ((class described-class) name &rest args)
+  
+  (call-next-method))
+
+(defmethod direct-slot-definition-class ((class described-class) &rest initargs)
+  (let ((slot-class (call-next-method))) 
+    (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
+
+(defclass described-class-direct-slot-definition ()
   ())
 
+(defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
+  (call-next-method))
+  
 (defmethod validate-superclass
            ((class described-class)
             (superclass standard-class))
   t)
 
-(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
+(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
   (declare (dynamic-extent initargs))
   (finalize-inheritance class)
-  (ensure-description-for-class class))
-
+  (ensure-description-for-class class :direct-slot-specs direct-slots 
+				      :direct-superclasses  direct-superclasses
+				      :attributes (slot-value class 'attributes)))
 
-(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
   (declare (dynamic-extent initargs))
   (finalize-inheritance class)
-  (ensure-description-for-class class))
+  (ensure-description-for-class class :direct-slot-specs direct-slots 
+				      :direct-superclasses direct-superclasses
+				      :attributes (slot-value class 'attributes)))
 
-(defclass described-standard-class (standard-class described-class) ())
+(defclass described-standard-class (described-class standard-class ) ())
 
 (defmethod validate-superclass
     ((class described-standard-class)
@@ -88,7 +136,4 @@
       (find-description 'standard-object)))
 
 
-		      
-		       
-  
 
diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp
index aa71065..ab1dd39 100644
--- a/src/standard-descriptions/edit.lisp
+++ b/src/standard-descriptions/edit.lisp
@@ -1,6 +1,5 @@
 (in-package :lisp-on-lines)
 
-
 (define-description editable ()
   ()
   (:mixinp t))
@@ -19,38 +18,51 @@
     :accessor attribute-setter
     :initform nil)
    (attribute-editor 
-    :initarg :input 
+    :initarg :editor
     :layered t
     :accessor attribute-editor
-    :initform nil
+    :initform (make-instance 'attribute-editor)
     :documentation "This ones a bit odd")))
 
-(defmethod attribute-editor :around (attribute)
-  (flet ((find-editor-class (spec)
-	   (let ((class (getf spec :class))
-		 (type (getf spec :type)))
-	     (or class (when (and type (symbolp type)) 
-			 (intern (format nil "~A-~A" type 'attribute-editor)))
-		 'string-attribute-editor))))
-  (let ((editor? (call-next-method)))
-    (if (listp editor?)
-	(setf (attribute-editor attribute)
-	      (apply #'make-instance (find-editor-class editor?) 
-		     editor?))
-	(call-next-method)))))
-
+(defmethod shared-initialize :after ((object standard-attribute) 
+				      slots &rest args &key input &allow-other-keys)
+
+  (when input 
+    (setf (attribute-editor object) 
+	  (apply #'make-instance (find-editor-class input)
+		 input))))
+
+      
+(defun find-editor-class (spec)
+  (let ((class (getf spec :class))
+	(type (getf spec :type)))
+    (or class (when 
+		  (and type (symbolp type)) 
+		(let ((name (format nil "~A-~A" type 'attribute-editor)))
+		  (or (find-class (intern name (symbol-package type)) nil)
+		      (find-class (intern name) nil)
+		      'string-attribute-editor))))))
 
 (defclass attribute-editor ()
     ((type :initarg :type
-	   :initform 'string)
+	   :initform 'string
+	   :accessor attribute-editor-type)
      (parser :initarg :parse-using
 	     :initform 'identity
 	     :accessor attribute-editor-parsing-function)
      (prompt :initarg :prompt 
-	     :initform nil)))
+	     :initform nil)
+     (unbound-value
+	 :initarg :unbound-value
+       :initform "")))
+
+
 
 (defclass string-attribute-editor (attribute-editor) ())
 (defclass text-attribute-editor (string-attribute-editor) ())
+
+(deftype password () 'string)
+
 (defclass password-attribute-editor (string-attribute-editor) ())
 
 (defclass number-attribute-editor (attribute-editor) ()
@@ -94,6 +106,12 @@
 (define-layered-method attribute-editp 
   :in-layer #.(defining-description 'editable)
   ((attribute standard-attribute))
+  (let ((value (attribute-value attribute)))
+  (unless (or (unbound-slot-value-p value)
+	      (typep value 
+		     (attribute-editor-type 
+		      (attribute-editor attribute))))
+    (return-from attribute-editp nil)))
   (let ((edit?       (call-next-method)))
     (if (eq :inherit edit?)
 	(attribute-value (find-attribute 
diff --git a/src/standard-descriptions/list.lisp b/src/standard-descriptions/list.lisp
index 71c65f2..133ee69 100644
--- a/src/standard-descriptions/list.lisp
+++ b/src/standard-descriptions/list.lisp
@@ -1,8 +1,23 @@
 (in-package :lisp-on-lines)
 
-(define-description cons ()
+
+(define-layered-class list-attribute (standard-attribute)
+ ((item-args :initform nil :initarg :item :layered t :special t)))
+
+(define-layered-method display-attribute-value 
+  ((attribute list-attribute))
+  (arnesi:dolist* (item (attribute-value attribute))
+    (apply #'display *display* item (slot-value attribute 'item-args))))
+
+(define-description list ()
+ ((list :attribute-class list-attribute
+	 :function #'identity
+	 :attributes nil)))
+
+(define-description cons (list)
   ((car :label "First" :function #'car)
-   (cdr :label "Rest"  :function #'cdr)))
+   (cdr :label "Rest"  :function #'cdr)
+   ))
 
 (define-description cons ()
   ((editp :value t :editp nil)
@@ -10,6 +25,10 @@
    (cdr :setter #'rplacd))
   (:in-description editable))
 
+(define-description cons ()
+  ((active-attributes :value '(list)))
+  (:in-description inline))
+
 (define-layered-method description-of ((c cons))
  (find-description 'cons))
 		       
diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index 08a846a..0dfe331 100644
--- a/src/standard-descriptions/t.lisp
+++ b/src/standard-descriptions/t.lisp
@@ -40,12 +40,14 @@
   (:method (attribute)
     (display-using-description attribute *display* (attribute-object attribute))))
 
+
 (define-layered-function display-attribute-label (attribute)
   (:method (attribute)
     (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
 	   
 
 
+
 (define-layered-function display-attribute-value (attribute)
   (:method (attribute)
     (flet ((disp (val &rest args)
@@ -55,12 +57,16 @@
 		    args)))
 	     
     (let ((val (attribute-value attribute)))
-      (if (eql val (attribute-object attribute))
+      (if (and (not (slot-boundp attribute 'active-attributes))
+	       (eql val (attribute-object attribute)))
 	  (generic-format *display* (funcall (attribute-value-formatter attribute) val))
 	  (with-active-descriptions (inline)
-	    (if (slot-boundp attribute 'active-attributes)
-		(disp val :attributes (slot-value attribute 'active-attributes))
-		(disp val))))))))
+	    (cond ((slot-value attribute 'value-formatter)
+		   (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
+		   ((slot-boundp attribute 'active-attributes)
+		    (disp val :attributes (slot-value attribute 'active-attributes)))
+		   (t
+		    (disp val)))))))))
 
 (define-layered-method display-using-description 
   ((attribute standard-attribute) display object &rest args)
@@ -69,6 +75,19 @@
     (display-attribute-label attribute))
   (display-attribute-value attribute))
 
+(define-layered-method display-attribute :around
+  ((attribute standard-attribute))
+    (funcall-with-layer-context 
+   (modify-layer-context (current-layer-context) 
+			 :activate (attribute-active-descriptions attribute)
+			 :deactivate (attribute-inactive-descriptions attribute))
+   (lambda () 
+     (call-next-method))))
+
+(define-layered-method display-attribute :before
+  ((attribute standard-attribute))
+)
+
 (define-display ((description t))
  (let ((attributes (attributes description)))
    (display-attribute (first attributes))
diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 0a8c205..4ec32cc 100644
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -24,7 +24,8 @@
 (define-layered-class html-attribute ()
   ((css-class :accessor attribute-css-class 
 	      :initform "lol-attribute")
-   (dom-id :accessor attribute-dom-id :initform nil)))
+   (dom-id :accessor attribute-dom-id :initform nil)
+   (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
 
 (define-layered-class standard-attribute
   :in-layer #.(defining-description 'html-description)
@@ -33,25 +34,27 @@
 
 (define-layered-function display-html-attribute-label (object attribute)
   (:method (object attribute)
+    
     (let ((label (attribute-label attribute)))
-      	   (<:label 
+      (when (or label (attribute-display-empty-label-p attribute))
+      	   (<:td (<:label 
 	    :class "lol-attribute-label"
 	    (when label 
 	      (<:as-html 
 	       (with-output-to-string (*display*)
-		 (display-attribute-label attribute)))))))
+		 (display-attribute-label attribute)))))))))
   (:method 
       :in-layer #.(defining-description 'inline)
       (object attribute)
     (let ((label (attribute-label attribute)))
       (when label
-		 (<:as-html 
+		 (<:as-html
 	  (with-output-to-string (*display*)
 	    (display-attribute-label attribute)))))))
 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)
-    (<:span 
+    (<:td 
 	:class "lol-attribute-value"
 	(<:as-html   
 	 (display-attribute-value attribute))))
@@ -63,7 +66,7 @@
 (define-layered-function display-html-attribute (object attribute)
   
   (:method (object attribute)
-    (<:div 
+    (<:tr 
      :class (attribute-css-class attribute)
      (when (attribute-dom-id attribute) 
        :id (attribute-dom-id attribute))
@@ -87,22 +90,41 @@
  (display-html-attribute object attribute))
 
 
+(defun capture-description (attribute function)
+   (let ((obj (described-object (attribute-description attribute))))
+   (lambda (&rest args)
+     (dletf (((described-object attribute) obj))
+       (apply function args)))))
+
 (defun make-attribute-value-writer (attribute)
- (let ((obj (described-object (attribute-description attribute))))
+ (let ((obj (described-object (attribute-description attribute)))
+       (value (attribute-value attribute)))
    (lambda (val)
      (dletf (((described-object attribute) obj))
-       (setf (attribute-value attribute) 
-	     (parse-attribute-value attribute val))))))
+       (with-active-descriptions (editable)
+	 (unless (and (unbound-slot-value-p value)
+		      (equal "" val))
+	 (setf (attribute-value attribute) 
+	     (parse-attribute-value attribute val))))))))
+
 
+(defmethod html-attribute-value (attribute)
+  (let ((val (attribute-value attribute)))
+    (if (unbound-slot-value-p val)
+	""
+	val)))
 
 (defmethod display-html-attribute-editor (attribute editor)
   (<lol:input :type "text"
-	      :reader (attribute-value attribute)
+	      :reader (html-attribute-value attribute)
 	      :writer (make-attribute-value-writer attribute)))
 
+(defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
+  (call-next-method))
+
 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
   (<lol:input :type "password"
-	      :reader (attribute-value attribute)
+	      :reader (html-attribute-value attribute)
 	      :writer (make-attribute-value-writer attribute)))
 
 
@@ -114,11 +136,10 @@
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)
 
-    (<:span 
+    (<:td
 	:class "lol-attribute-value"
     (if (attribute-editp attribute)	
 	(display-attribute-editor attribute)
-    
 	(call-next-method))))		
 
 (define-layered-function display-html-description (description display object &optional next-method)
@@ -126,34 +147,45 @@
     (<:style
      (<:as-html "
 
+
+
 div.lol-description .lol-attribute-label, 
 div.lol-description .lol-attribute-value {
       display: block;
       width: 69%;
       float: left;
       margin-bottom: 1em;
+border:1px solid black;
 
 }
 div.lol-description 
 .lol-attribute-label {
      text-align: right;
      width: 24%;
-     padding-right: 20px;
+     padding-right: 1em;
 }
 
+span.lol-attribute-value .lol-attribute-value (
+ border: 1px solid red;}
+
 
 div.lol-description 
 br {
 clear: left;
-}"))
+}
+
+.clear {clear:left}"
+
+))
 		       
     (with-attributes (css-class dom-id) description
    
 
-      (<:div 
+      (<:table
        :class (list (attribute-value css-class) "lol-description" "t")
        :id    (attribute-value dom-id)
-       (funcall next-method)))))
+       (funcall next-method)
+       (<:br :class "clear")))))
 		       
 
 (define-layered-method display-html-description 
@@ -172,6 +204,11 @@ clear: left;
   (display-html-description description display object (lambda ()
 							 (call-next-method))))
 
+(define-layered-method display-html-attribute-value 
+  (object (attribute list-attribute))
+   (<:ul
+     (arnesi:dolist* (item (attribute-value attribute))
+       (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))
 
 
 
diff --git a/src/ucw/lol-tags.lisp b/src/ucw/lol-tags.lisp
index abf7982..2d09859 100644
--- 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))
   
   
   
diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp
index 7e143ef..935acb7 100644
--- a/src/ucw/packages.lisp
+++ b/src/ucw/packages.lisp
@@ -2,7 +2,7 @@
 (defpackage lisp-on-lines-ucw
   (:documentation "An LoL Layer over ucw.basic")
   (:nicknames #:lol-ucw)
-  (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml :puri)
+  (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml)
   (:shadow 
    #:standard-window-component
    #:make-action
diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 0fb99f5..533e8fd 100644
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -24,10 +24,11 @@
 		  (apply #'make-instance name args)))
 
 (defun/cc answer (&optional val)
-  (answer-component *source-component* 
-	  val))
+  (let ((child *source-component*))
+    (setf *source-component* (ucw::component.calling-component child))
+    (answer-component child val)))
 
-(defclass described-component-class (standard-component-class described-class)
+(defclass described-component-class (described-class standard-component-class )
   ())
 
 (defmacro defaction (&rest args-and-body)
@@ -66,8 +67,12 @@
 	      (return action-id))))
    (call-next-method)))
 
+
+
+
+
 (defcomponent standard-window-component 
-  (ucw:basic-window-component)
+  (ucw::basic-window-component)
   ((body
     :initform nil
     :accessor window-body