tons of small changes to bring this up to date with maxclaims 2.0

darcs-hash:20090609181300-39164-c6b993650d1b1dcb650cc7acb7a7bc6bbcc4b15b.gz

diff --git a/src/description-class.lisp b/src/description-class.lisp
index e599444..bba188e 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -96,6 +96,14 @@
    (remove 'described-object (class-slots (class-of description))
           :key #'slot-definition-name)))
 
    (remove 'described-object (class-slots (class-of description))
           :key #'slot-definition-name)))
 

+(defmacro with-described-object ((object description &rest args)
+                                &body body)
+    `(funcall-with-described-object 
+      (lambda () ,@body)
+      ,object
+      ,description
+      ,@args))
+

 (defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
 
     (loop 
 (defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
 
     (loop 

diff --git a/src/description.lisp b/src/description.lisp
index 073dc94..2ce2c81 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -101,13 +101,7 @@
                        function))))))))
 
 
                        function))))))))
 
 

-(defmacro with-described-object ((object description &rest args)
-                                &body body)
-    `(funcall-with-described-object 
-      (lambda () ,@body)
-      ,object
-      ,description
-      ,@args))
+

                   
 (defmacro define-description (name &optional superdescriptions &body options)
   (let ((description-name (defining-description name)))     
                   
 (defmacro define-description (name &optional superdescriptions &body options)
   (let ((description-name (defining-description name)))     

diff --git a/src/display.lisp b/src/display.lisp
index 7de1c63..6078e83 100644 (file)
--- a/src/display.lisp
+++ b/src/display.lisp
@@ -17,10 +17,18 @@
   (dolist (d activate context)
     (setf context (adjoin-layer (find-description d)
                                context))))
   (dolist (d activate context)
     (setf context (adjoin-layer (find-description d)
                                context))))

-  
-

 
 

+(defun funcall-with-attribute-context (attribute thunk)
+  (funcall-with-layer-context 
+   (modify-layer-context (current-layer-context) 
+                        :activate (attribute-active-descriptions attribute)
+                        :deactivate (attribute-inactive-descriptions attribute))
+   thunk))

 
 

+(defmacro with-attribute-context ((attribute) &body body)
+  `(funcall-with-attribute-context ,attribute (lambda () ,@body)))
+  
+  

 (defun display (display object &rest args &key deactivate activate &allow-other-keys)
 
   (funcall-with-layer-context 
 (defun display (display object &rest args &key deactivate activate &allow-other-keys)
 
   (funcall-with-layer-context 


@@ -42,8 +50,6 @@
 
 
 
 
 
 

-
-

 (defun display/d (&rest args)
   (apply #'display-using-description args))
 
 (defun display/d (&rest args)
   (apply #'display-using-description args))
 

diff --git a/src/packages.lisp b/src/packages.lisp
index e456cf0..07ff448 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -14,6 +14,7 @@
    #:find-description   
    #:description-of
    #:define-description
    #:find-description   
    #:description-of
    #:define-description

+   #:defining-description

    #:described-object
    #:with-described-object
    #:described-class
    #:described-object
    #:with-described-object
    #:described-class


@@ -39,12 +40,15 @@
    #:attribute-delimiter
    #:attribute-slot-name
    #:label
    #:attribute-delimiter
    #:attribute-slot-name
    #:label

+   #:attribute-active-p

    #:attribute-function
    #:attribute-value
    #:display-attribute-value
    #:active-attributes
    #:attribute-delimiter
    #:standard-attribute
    #:attribute-function
    #:attribute-value
    #:display-attribute-value
    #:active-attributes
    #:attribute-delimiter
    #:standard-attribute

+   #:funcall-with-attribute-context
+   #:with-attribute-context

 
    ;; Standard Library
    
 
    ;; Standard Library
    

diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp
index b04914e..3f349dd 100644 (file)
--- a/src/standard-descriptions/inline.lisp
+++ b/src/standard-descriptions/inline.lisp
@@ -15,6 +15,16 @@
   ()
   ())
 
   ()
   ())
 

+(defun display-inline (object &rest args)
+  (with-active-descriptions (inline)
+    (apply #'display *display* object args)))
+
+(defun display-inline-attribute (attribute value)
+  (if (ignore-errors (lol::attribute-active-attributes attribute))
+      (handler-case (display-inline value :attributes (lol::attribute-active-attributes attribute))
+       (error ()
+         (display-inline value)))
+      (display-inline value)))
+
+

 
 

-(define-display :in-description inline ((description t))               
-               (call-next-method))

diff --git a/src/standard-descriptions/list.lisp b/src/standard-descriptions/list.lisp
index 1d5737d..0beb994 100644 (file)
--- a/src/standard-descriptions/list.lisp
+++ b/src/standard-descriptions/list.lisp
@@ -12,8 +12,7 @@
     (loop 
        :for cons :on list
        :do (let ((item (first cons
     (loop 
        :for cons :on list
        :do (let ((item (first cons

-)))
-                (break "Display T ~A" item) 
+))) 

             (dletf (((attribute-object attribute) item))
               (apply #'display *display* item (slot-value attribute 'item-args))
               (unless (endp (cdr cons))
             (dletf (((attribute-object attribute) item))
               (apply #'display *display* item (slot-value attribute 'item-args))
               (unless (endp (cdr cons))

diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index 5baf369..223261f 100644 (file)
--- a/src/standard-descriptions/t.lisp
+++ b/src/standard-descriptions/t.lisp
@@ -46,6 +46,7 @@
     (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
           
 (define-layered-function display-attribute-value (attribute)
     (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
           
 (define-layered-function display-attribute-value (attribute)

+  (:method-combination arnesi:wrapping-standard)

   (:method (attribute)
     (flet ((disp (val &rest args)
             (apply #'display *display* val 
   (:method (attribute)
     (flet ((disp (val &rest args)
             (apply #'display *display* val 


@@ -103,7 +104,7 @@
 
 (define-display ((description t))
  (let ((attributes (attributes description)))
 
 (define-display ((description t))
  (let ((attributes (attributes description)))

-   (display-attribute (first attributes))
+   (when (first attributes)(display-attribute (first attributes)))

    (dolist (attribute (rest attributes) (values))
      (generic-format *display* 
       (attribute-value 
    (dolist (attribute (rest attributes) (values))
      (generic-format *display* 
       (attribute-value 

diff --git a/src/standard-descriptions/validate.lisp b/src/standard-descriptions/validate.lisp
index 5a5fb62..6bfeaeb 100644 (file)
--- a/src/standard-descriptions/validate.lisp
+++ b/src/standard-descriptions/validate.lisp
@@ -64,7 +64,6 @@
        t)))
 
 
        t)))
 
 

-

 (defun validp (object)
   (with-described-object (object nil)
     (every #'identity (mapcar (lambda (attribute)
 (defun validp (object)
   (with-described-object (object nil)
     (every #'identity (mapcar (lambda (attribute)

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 83847ed..94a8add 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -24,6 +24,7 @@
   ((css-class :accessor attribute-css-class 
              :initform "lol-attribute")
    (dom-id :accessor attribute-dom-id :initform nil)
   ((css-class :accessor attribute-css-class 
              :initform "lol-attribute")
    (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
    (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
 
 (define-layered-class standard-attribute


@@ -47,26 +48,26 @@
       (object attribute)
     (let ((label (attribute-label attribute)))
       (when label
       (object attribute)
     (let ((label (attribute-label attribute)))
       (when label

-                (<:as-html
-         (with-output-to-string (*display*)
-           (display-attribute-label attribute)))))))
+       (<:as-html (display-attribute-label attribute))))))

 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)
 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)

+

     (<:td 
     (<:td 

-       :class "lol-attribute-value"
-       (<:as-html   
-        (display-attribute-value attribute))))
+     :class "lol-attribute-value"
+     (<:as-html   
+      (display-attribute-value attribute))))

 
   (:method 
     :in-layer #.(defining-description 'inline) (object attribute)
     (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 
 (define-layered-function display-html-attribute (object attribute)
   
   (:method (object attribute)
     (<:tr 

-     :class (attribute-css-class attribute)
+     :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)
      (when (attribute-dom-id attribute) 
        :id (attribute-dom-id attribute))
      (display-html-attribute-label object attribute)


@@ -79,8 +80,10 @@
        :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))

-       (display-html-attribute-label object attribute)
-       (display-html-attribute-value object 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)
 
 (define-layered-method display-using-description 
   :in-layer #.(defining-description 'html-description)


@@ -137,47 +140,15 @@
 (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)
 

-    (<:td
-       :class "lol-attribute-value"
+

     (if (attribute-editp attribute)    
     (if (attribute-editp attribute)    

-       (display-attribute-editor attribute)
-       (call-next-method))))           
+           (<: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))
 
 (define-layered-function display-html-description (description display object &optional next-method)
   (:method (description display object &optional (next-method #'display-using-description))

-    (<: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: 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
    
                       
     (with-attributes (css-class dom-id) description
    

diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 9aea34d..8ffe33d 100644 (file)
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -7,7 +7,7 @@
   (:metaclass closer-mop:funcallable-standard-class))
 
 
   (:metaclass closer-mop:funcallable-standard-class))
 
 

-(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
+(setf ucw-core::*default-action-class* 'lisp-on-lines-action)

 
 
 (defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
 
 
 (defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)


@@ -22,7 +22,7 @@
          (funcall next-method)))
     ))
 
          (funcall next-method)))
     ))
 

-(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
+(defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)

      (let ((lol::*invalid-objects* (make-hash-table)))
        (handler-bind ((lol::validation-condition 
                       (lambda (c)
      (let ((lol::*invalid-objects* (make-hash-table)))
        (handler-bind ((lol::validation-condition 
                       (lambda (c)