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 (file)
--- 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)))))
            (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))))))
          
 
           (description-attributes description))))))
          
 

diff --git a/src/packages.lisp b/src/packages.lisp
index 44a6977..234a7be 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -17,6 +17,7 @@
    #:insert-into   
    #:select-objects
    #:select-only-n-objects
    #:insert-into   
    #:select-objects
    #:select-only-n-objects

+   #:insert-object

    
 ;; Descriptions
    #:find-description
    
 ;; Descriptions
    #:find-description


@@ -28,6 +29,7 @@
    #:with-active-descriptions
    #:with-inactive-descriptions
 
    #:with-active-descriptions
    #:with-inactive-descriptions
 

+

    ;; Displays
    #:define-display
    #:display
    ;; Displays
    #:define-display
    #:display


@@ -39,15 +41,27 @@
    #:find-attribute
    #:attribute
    #:attributes
    #:find-attribute
    #:attribute
    #:attributes

+   #:attribute-object

    #:attribute-label
    #:attribute-label

+   #:label

    #:attribute-function
    #:attribute-value
    #:attribute-function
    #:attribute-value

+   #:display-attribute-value

    #:active-attributes
    #:active-attributes

-
+   #:attribute-delimiter
+   #:standard-attribute

    ;; Standard Library
    ;; Standard Library

+   
+   ;; editing

    #:editable
    #:editable

+   #:attribute-editor

    #:string-attribute-editor
    #:number-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 (file)
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -19,6 +19,9 @@
 
 
 ;;;; now the rofl code itself
 
 
 ;;;; 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))
 
 (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 (file)
--- 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+))
 
       (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
                                 :collect (slot-definition-name slot) :into names
                                 :finally (return (cons `(:name active-attributes

-                                                         :value ',names)
+                                                         :value ',(or attributes names))

                                                        slots)))        
                                                        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)
     (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 ()
 
 
 (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 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)
   (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)
   (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)
 
 (defmethod validate-superclass
     ((class described-standard-class)


@@ -88,7 +136,4 @@
       (find-description 'standard-object)))
 
 
       (find-description 'standard-object)))
 
 

-                     
-                      
-  

 
 

diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp
index aa71065..ab1dd39 100644 (file)
--- a/src/standard-descriptions/edit.lisp
+++ b/src/standard-descriptions/edit.lisp
@@ -1,6 +1,5 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

-

 (define-description editable ()
   ()
   (:mixinp t))
 (define-description editable ()
   ()
   (:mixinp t))


@@ -19,38 +18,51 @@
     :accessor attribute-setter
     :initform nil)
    (attribute-editor 
     :accessor attribute-setter
     :initform nil)
    (attribute-editor 

-    :initarg :input 
+    :initarg :editor

     :layered t
     :accessor attribute-editor
     :layered t
     :accessor attribute-editor

-    :initform nil
+    :initform (make-instance 'attribute-editor)

     :documentation "This ones a bit odd")))
 
     :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
 
 (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 
      (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) ())
 
 (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) ()
 (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))
 (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 
   (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 (file)
--- a/src/standard-descriptions/list.lisp
+++ b/src/standard-descriptions/list.lisp
@@ -1,8 +1,23 @@
 (in-package :lisp-on-lines)
 
 (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)
   ((car :label "First" :function #'car)

-   (cdr :label "Rest"  :function #'cdr)))
+   (cdr :label "Rest"  :function #'cdr)
+   ))

 
 (define-description cons ()
   ((editp :value t :editp nil)
 
 (define-description cons ()
   ((editp :value t :editp nil)


@@ -10,6 +25,10 @@
    (cdr :setter #'rplacd))
   (:in-description editable))
 
    (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))
                       
 (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 (file)
--- 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))))
 
   (: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-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)
 (define-layered-function display-attribute-value (attribute)
   (:method (attribute)
     (flet ((disp (val &rest args)


@@ -55,12 +57,16 @@
                    args)))
             
     (let ((val (attribute-value attribute)))
                    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)
          (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)
 
 (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))
 
     (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))
 (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 (file)
--- 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")
 (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)
 
 (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)
 
 (define-layered-function display-html-attribute-label (object attribute)
   (:method (object attribute)

+    

     (let ((label (attribute-label 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*)
            :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
   (: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)
          (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))))
        :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)
 (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))
      :class (attribute-css-class attribute)
      (when (attribute-dom-id attribute) 
        :id (attribute-dom-id attribute))


@@ -87,22 +90,41 @@
  (display-html-attribute object attribute))
 
 
  (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)
 (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))
    (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"
 
 (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)))
 
              :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"
 (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)))
 
 
              :writer (make-attribute-value-writer attribute)))
 
 


@@ -114,11 +136,10 @@
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)
 
 (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)
        :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)
        (call-next-method))))           
 
 (define-layered-function display-html-description (description display object &optional next-method)


@@ -126,34 +147,45 @@
     (<:style
      (<:as-html "
 
     (<:style
      (<:as-html "
 

+
+

 div.lol-description .lol-attribute-label, 
 div.lol-description .lol-attribute-value {
       display: block;
       width: 69%;
       float: left;
       margin-bottom: 1em;
 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%;
 
 }
 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;
 
 div.lol-description 
 br {
 clear: left;

-}"))
+}
+
+.clear {clear:left}"
+
+))

                       
     (with-attributes (css-class dom-id) description
    
 
                       
     (with-attributes (css-class dom-id) description
    
 

-      (<:div 
+      (<:table

        :class (list (attribute-value css-class) "lol-description" "t")
        :id    (attribute-value dom-id)
        :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 
                       
 
 (define-layered-method display-html-description 


@@ -172,6 +204,11 @@ clear: left;
   (display-html-description description display object (lambda ()
                                                         (call-next-method))))
 
   (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 (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)))
   `(<: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 (file)
--- 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)
 (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
   (:shadow 
    #:standard-window-component
    #:make-action

diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 0fb99f5..533e8fd 100644 (file)
--- 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)
                  (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)
   ())
 
 (defmacro defaction (&rest args-and-body)


@@ -66,8 +67,12 @@
              (return action-id))))
    (call-next-method)))
 
              (return action-id))))
    (call-next-method)))
 

+
+
+
+

 (defcomponent standard-window-component 
 (defcomponent standard-window-component 

-  (ucw:basic-window-component)
+  (ucw::basic-window-component)

   ((body
     :initform nil
     :accessor window-body
   ((body
     :initform nil
     :accessor window-body