added the image attribute and a naive image picker

[clinton/lisp-on-lines.git] / src / standard-display.lisp

diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index c756096..9bcf3ff 100644 (file)
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -11,6 +11,8 @@
 
 (deflayer wrap-form)
 
 
 (deflayer wrap-form)
 

+(deflayer as-table)
+

 (define-attributes (contextl-default)
   (:viewer viewer)
   (:editor editor)
 (define-attributes (contextl-default)
   (:viewer viewer)
   (:editor editor)


@@ -23,53 +25,61 @@
             (apply #'display ,component thing args)))
       ,@body)))
 
             (apply #'display ,component thing args)))
       ,@body)))
 

-(defmacro call-display (object &rest args)
-  `(call-component self (make-instance 'standard-display-component
-                        :display #'(lambda (component)
-                                     (with-component (component)
-                                       (<:as-html ,object)
-                                       (display ,object ,@args))))))

 
 

-;;;;; Macros
+(define-layered-function find-display-type (object))

 
 

-(defmacro do-attributes ((var occurence attributes) &body body)
-  (with-unique-names (att plist type)
-    `(loop for ,att in ,attributes
-      do (let* ((,att (ensure-list ,att))
-               (,plist (rest ,att))
-               (,type (getf ,plist :type))
-               (,var (if ,type
-                         (make-attribute :name (first ,att) :type ,type :plist ,plist)
-                         (find-attribute ,occurence (first ,att)))))
-          (flet ((display-attribute* (component object)
-                   (display-using-description
-                    ,var
-                    component
-                    object
-                    (rest ,att))))
-            (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)        
-              ,@body))))))
+(define-layered-method find-display-type (object)
+  'viewer)
+
+(define-layered-function find-display-layers (object))

 
 

+(define-layered-method find-display-layers (object)
+  "layered function"
+  nil)
+
+(defmacro call-display (component object &rest args)
+  `(call-component ,component (make-instance 'standard-display-component
+                        :display #'(lambda (component)
+                                     (with-component (component)
+                                       (display ,component ,object ,@args))))))

 
 (defmethod find-plist (object)
   (list))
 
 (defmethod find-plist ((attribute standard-attribute))
 
 (defmethod find-plist (object)
   (list))
 
 (defmethod find-plist ((attribute standard-attribute))

+  (warn "atttributre plist ~A" (attribute.plist attribute))

   (attribute.plist attribute))
 
 (defmacro with-plist ((plist-form &optional prefix)  &body body)
   (with-unique-names (p)
     (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
   (attribute.plist attribute))
 
 (defmacro with-plist ((plist-form &optional prefix)  &body body)
   (with-unique-names (p)
     (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))

-         (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP")))))
+         (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
+         (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))

       `(let ((,p ,plist-form))
        (flet ((,get  (p)
                 (getf ,p p))
               (,set (p v)
       `(let ((,p ,plist-form))
        (flet ((,get  (p)
                 (getf ,p p))
               (,set (p v)

-                (setf (getf ,p p) v)))
-         (declare (ignorable #',get #',set))
+                (setf (getf ,p p) v))
+              (,props ()
+                ,p))
+         (declare (ignorable #',get #',set #',props))

          ,@body)))))
 
 
          ,@body)))))
 
 

+;;;;; Macros
+(defmacro do-attributes ((var occurence attributes) &body body)
+  (with-unique-names (att plist type)
+    `(loop for ,att in ,attributes
+      do (let* ((,att (ensure-list ,att))
+               (,plist (rest ,att))
+               (,type (getf ,plist :type))
+               (,var (if ,type
+                         (make-attribute :name (first ,att) :type ,type :plist ,plist)
+                         (find-attribute ,occurence (first ,att)))))
+          (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)          
+            ,@body)))))
+
+

 (defmacro defdisplay ((&key
                       (in-layer nil layer-supplied-p)
                       (combination nil combination-supplied-p)
 (defmacro defdisplay ((&key
                       (in-layer nil layer-supplied-p)
                       (combination nil combination-supplied-p)


@@ -77,23 +87,25 @@
                       (component 'component)
                       ((:class object)  nil))
                      &body body)
                       (component 'component)
                       ((:class object)  nil))
                      &body body)

-
+  (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))

   `(define-layered-method display-using-description
     ,@(when layer-supplied-p `(:in-layer ,in-layer))
     ,@(when combination-supplied-p `(,combination))
     (,description ,component
   `(define-layered-method display-using-description
     ,@(when layer-supplied-p `(:in-layer ,in-layer))
     ,@(when combination-supplied-p `(,combination))
     (,description ,component

-     ,(if object (if (listp object) object (list object object)) 'object)  properties)
-    (declare (ignorable display-attribute))
+     ,class-spec  properties)
+    

 
     (with-plist ((plist-union properties (find-plist ,(car description))))
       
       ,(if (not description-supplied-p)
 
     (with-plist ((plist-union properties (find-plist ,(car description))))
       
       ,(if (not description-supplied-p)

-          `(flet ((display-attribute (attribute)
-                   (let ((a (ensure-list attribute)))
-                     (display-using-description (find-attribute ,(car description) (car a)) ,component ,(car (ensure-list object))  (cdr a)))))
+          `(flet ((attributes ()
+                   (or (getp :attributes)
+                       (list-slots ,(car (ensure-list class-spec))))))
+            (declare (ignorable #'attributes))

             
             ,@body)
             
             ,@body)

-          `(progn ,@body)))))
+          `(progn ,@body))))  )
+  )

 
 
 (define-layered-function display (component object &rest args)
 
 
 (define-layered-function display (component object &rest args)


@@ -102,10 +114,8 @@
 
  default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
 
 
  default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
 

-
-

 (define-layered-method display
 (define-layered-method display

-    ((component t) (object t) &rest args &key layers (type 'viewer)  &allow-other-keys)  
+    ((component t) (object standard-object) &rest args &key layers (type 'viewer)  &allow-other-keys)

   (let* ((occurence (find-occurence object))
         (plist (attribute.plist
                 (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
   (let* ((occurence (find-occurence object))
         (plist (attribute.plist
                 (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))


@@ -117,18 +127,12 @@
      layers             
      #'display-using-description  occurence component object (plist-union args plist))))
 
      layers             
      #'display-using-description  occurence component object (plist-union args plist))))
 

+

 (define-layered-method display
 (define-layered-method display

-    ((component t) (object symbol) &rest args &key (layers  '(+ viewer)) &allow-other-keys)
+  ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)

   (funcall-with-layers 
   (funcall-with-layers 

-     layers             
-     #'display-using-description  t component object args))
-
-
-(define-layered-method display ((component t) (list list) &rest args)
-  "The Default Display* for LISTS"
-  (<:ul
-   (dolist* (item list)
-     (<:li  (apply #'display component item args)))))
+   layers               
+   #'display-using-description  t component object args))

 
 
 (define-layered-function display-using-description (description component object properties)
 
 
 (define-layered-function display-using-description (description component object properties)


@@ -140,58 +144,80 @@
   (declare (ignore component properties description))
   (<:as-html object))
 
   (declare (ignore component properties description))
   (<:as-html object))
 

+;;;; * Object Presentations

 (define-layered-method display-using-description
 (define-layered-method display-using-description

-    ((occurence standard-occurence) component object properties)
+  ((occurence standard-occurence) component object properties)

 
   (with-plist (properties o)
     (loop for att in (or (o-getp :attributes) (list-slots object))
          do (let* ((att (ensure-list att))
                    (attribute (find-attribute occurence (first att))))
 
   (with-plist (properties o)
     (loop for att in (or (o-getp :attributes) (list-slots object))
          do (let* ((att (ensure-list att))
                    (attribute (find-attribute occurence (first att))))

-              (warn "trying to render ~A in ~A" attribute object)

               (with-plist ((plist-union (rest att) (find-plist attribute)))
                 (<:p :class "attribute"
               (with-plist ((plist-union (rest att) (find-plist attribute)))
                 (<:p :class "attribute"

-                     (<:span :class "label" (<:as-html (getp :label) " "))        
+                     (and (getp :show-labels-p) (<:span :class "label" (<:as-html (or (getp :label) "")  " ")))           

                      (display-using-description
                       attribute
                       component
                       object
                       (rest att))))))))
 
                      (display-using-description
                       attribute
                       component
                       object
                       (rest att))))))))
 

-(define-layered-method display-using-description
-  :in-layer one-line ((occurence standard-occurence) component object properties)
-  (with-plist (properties occurence)
-      (do-attributes (attribute occurence (or (occurence-getp :attributes)
-                                             (list-slots object)))
-       (display-attribute* component object) (<:as-html " "))))

 
 
 
 

-(define-layered-method display-using-description ((attribute standard-attribute) component object properties)
-  (let ((p (lol:make-view object :type :viewer))
-       (name (attribute.name attribute)))
-    (when name (present-slot-view p name))))

 
 

+;;;; ** One line
+(defdisplay (:in-layer one-line)
+  "The one line presentation just displays the attributes with a #\Space between them"
+  (do-attributes (attribute occurence (or (getp :attributes)
+                                         (list-slots object)))
+       (display-using-description attribute component object (attribute-properties))
+       (<:as-html " ")))
+ 
+;;;; ** as-table
+
+(defdisplay (:in-layer as-table)
+  (<:table
+   (do-attributes (a occurence (attributes))
+     (<:tr
+      (<:td  (<:as-html (a-getp :label)))
+      (<:td (display-using-description a component object (a-properties)))))))
+
+;;;; List Displays
+(defdisplay (:class
+            (list list)
+            :description (desc t))
+  (<:ul
+   (dolist* (item list)
+     (<:li  (apply #'display component item properties)))))
+
+
+
+;;;; Attributes 

 (defdisplay (:in-layer
             editor
             :description (attribute standard-attribute))
 (defdisplay (:in-layer
             editor
             :description (attribute standard-attribute))

-  "Legacy editor using UCW presentations"
+    "Legacy editor using UCW presentations"

   (let ((p (lol:make-view object :type :editor)))
     (present-slot-view p (getf (find-plist attribute) :slot-name))))
 
   (let ((p (lol:make-view object :type :editor)))
     (present-slot-view p (getf (find-plist attribute) :slot-name))))
 

-
+(define-layered-method display-using-description
+    ((attribute standard-attribute) component object properties)
+  (let ((p (lol:make-view object :type 'mewa-viewer))
+       (name (attribute.name attribute)))
+    (when name (present-slot-view p name))))

 
 (defdisplay (:class
             (button (eql 'standard-form-buttons))
             :description (description t))
 
 (defdisplay (:class
             (button (eql 'standard-form-buttons))
             :description (description t))

-  (<ucw:submit :action (ok component)
-              :value "Ok.")
-
+    (<ucw:submit :action (ok component)
+                :value "Ok."))

 
 (defdisplay (:in-layer wrap-form
                       :combination :around)
   (<ucw:form
    :action (refresh-component component)
    (call-next-method)
 
 (defdisplay (:in-layer wrap-form
                       :combination :around)
   (<ucw:form
    :action (refresh-component component)
    (call-next-method)

-   (display component 'standard-form-buttons))))
+   (display component 'standard-form-buttons)))
+

 
 (defclass/meta test-class ()
   ((test-string :initform "test string" :type string))
 
 (defclass/meta test-class ()
   ((test-string :initform "test string" :type string))