Add dlambda + contextl hack

[clinton/lisp-on-lines.git] / src / ucw / html-description.lisp

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 8dae20a..94a8add 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -1,50 +1,187 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

-(export '(html-description))
+(export '(html-description) (find-package :lisp-on-lines))

 
 

+(defvar *escape-html* t)
+
+(defmethod generic-format ((display ucw-core:component) string &rest args)
+  (<:as-html (with-output-to-string (stream)
+              (apply #'call-next-method stream string args))))
+      

 (define-description html-description ()
 (define-description html-description ()

-  ((css-class  :value "lol-description")
+  ())
+
+(define-description t ()
+  ((css-class  :value "lol-description" :activep nil)

    (dom-id :function (lambda (x)
                       (declare (ignore x))
                       (symbol-name 
    (dom-id :function (lambda (x)
                       (declare (ignore x))
                       (symbol-name 

-                       (gensym "DOM-ID-")))))
-  (:mixinp t))
-
-
-(define-description t (html-description)
-  ()
+                       (gensym "DOM-ID-")))
+          :activep nil))

   (:in-description html-description))
 
 (define-layered-class html-attribute ()
   ((css-class :accessor attribute-css-class 
              :initform "lol-attribute")
   (:in-description html-description))
 
 (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)
+   (value-tag :accessor attribute-html-tag :initform nil :initarg :html-tag)
+   (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)
  (html-attribute)
  ())
 
 
 (define-layered-class standard-attribute
   :in-layer #.(defining-description 'html-description)
  (html-attribute)
  ())
 

-(define-display 
-  :in-description html-description ((description t))
- (with-attributes (css-class dom-id) description
-   
-   (<:div 
-    :class (attribute-value* css-class)
-    :id    (attribute-value* dom-id)
-    (dolist (attribute (attributes description))
-      (<:div 
+(define-layered-function display-html-attribute-label (object attribute)
+  (:method (object attribute)
+    
+    (let ((label (attribute-label attribute)))
+      (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)))))))))
+  (:method 
+      :in-layer #.(defining-description 'inline)
+      (object attribute)
+    (let ((label (attribute-label attribute)))
+      (when label
+       (<:as-html (display-attribute-label attribute))))))
+
+(define-layered-function display-html-attribute-value (object attribute)
+  (:method (object attribute)
+
+    (<:td 
+     :class "lol-attribute-value"
+     (<:as-html   
+      (display-attribute-value attribute))))
+
+  (:method 
+    :in-layer #.(defining-description 'inline) (object attribute)
+    (display-attribute-value attribute)))
+
+
+(define-layered-function display-html-attribute (object attribute)
+  
+  (:method (object attribute)
+    (<:tr 
+     :class (format nil "~A lol-attribute" (attribute-css-class attribute))
+     (when (attribute-dom-id attribute) 
+       :id (attribute-dom-id attribute))
+     (display-html-attribute-label object attribute)
+     (display-html-attribute-value object attribute)))
+  
+  (:method 
+      :in-layer #.(defining-description 'inline) 
+      (object attribute)
+      (<:span 

        :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))

-       (<:span 
-       :class "lol-attribute-label"
-       (<:as-html (attribute-label attribute)))
-       (<:span 
-       :class "lol-attribute-value"
-       (<:as-html (attribute-value* attribute))))))))
-     
-      
-  
-               
-  
+       (<:span :class "lol-attribute-label"
+       (display-html-attribute-label object attribute))
+       (<:span :class "lol-attribute-value"
+       (display-html-attribute-value object attribute)))))
+
+(define-layered-method display-using-description 
+  :in-layer #.(defining-description 'html-description)
+  :around ((attribute standard-attribute) display object &rest args)
+ (declare (ignore args))
+ (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)))
+       (value (attribute-value attribute)))
+   (lambda (val)
+     (dletf (((described-object attribute) obj))
+       (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)
+  (<ucw:input :type "text"
+             :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))
+  (<ucw:input :type "password"
+             :reader (html-attribute-value attribute)
+             :writer (make-attribute-value-writer attribute)))
+
+
+
+
+(define-layered-method display-attribute-editor 
+   :in-layer #.(defining-description 'html-description) (attribute)
+   (display-html-attribute-editor attribute (attribute-editor attribute)))
+                                            
+
+(define-layered-method display-html-attribute-value 
+  :in-layer #.(defining-description 'editable) (object attribute)
+
+
+    (if (attribute-editp attribute)    
+           (<:td
+            :class "lol-attribute-value"(display-attribute-editor attribute))
+       (call-next-method)))
+
+(define-layered-function display-html-description (description display object &optional next-method)
+  (:method (description display object &optional (next-method #'display-using-description))
+    
+                      
+    (with-attributes (css-class dom-id) description
+   
+
+      (<:table
+       :class (list (attribute-value css-class) "lol-description" "t")
+       :id    (attribute-value dom-id)
+       (funcall next-method)
+       (<:br :class "clear")))))
+                      
+
+(define-layered-method display-html-description 
+  :in-layer #.(defining-description 'inline) (description display object &optional next-method)
+  (with-attributes (css-class dom-id) description
+    (<:span
+     :class (list (attribute-value css-class) "lol-description")
+     :id    (attribute-value dom-id)
+     (funcall next-method))))
+
+
+(define-display 
+  :in-description html-description ((description t) 
+                                   (display ucw-core:component) 
+                                   object)
+  (display-html-description description display object (lambda ()
+                                                        (call-next-method))))
+
+(define-layered-method display-html-attribute-value 
+  (object (attribute list-attribute))
+  (let ((val (attribute-value attribute)))
+    (when (listp  val) 
+      (<:ul
+       (arnesi:dolist* (item (attribute-value attribute))
+
+        (dletf (((attribute-object attribute) item))
+          (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))
\ No newline at end of file