X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/2b0fd9c886908c6492c66cc30fcacf5fd600bf8e..301f28fd7c8390159aec06d93f815e8d02095fcc:/src/standard-display.lisp?ds=sidebyside

diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index 1845491..35d57e1 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -3,52 +3,36 @@
 ;;;; The Standard Layers
 (deflayer viewer)
 (deflayer editor)
-(deflayer creator)
+
+(define-layered-method label (anything)
+  nil)
+
+(defdisplay
+    :in-layer editor :around (description object)
+  "It is useful to remove the viewer layer when in the editing layer.
+This allows us to dispatch to a subclasses editor.
+"
+  (with-inactive-layers (viewer)
+    (call-next-method)))
+
+;;;; These layers affect the layout of the object
 (deflayer one-line)
 (deflayer as-table)
 (deflayer as-string)
 
 (defdisplay
   :in-layer as-string (d o)
-  (do-attributes (a d)
-    (display-attribute a o)
-    (<:as-is " ")))
+  (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+    (do-attributes (a d)
+      (display-attribute a o)
+      (<:as-is " "))))
 
 (defmethod list-slots (thing)
   (list 'identity))
 
-
-;;;; TODO : this doesn't work
-
-(defaction call-display-with-context ((from component) object context &rest properties)
-  (call-component self (make-instance 'standard-display-component
-				      :context context
-				      :object object
-				      :args (if (cdr properties)
-						 properties
-						 (car properties)))))
-
-(defmacro call-display (component object &rest properties)
-  `(let ()
-    (call-display-with-context ,component ,object nil  ,@properties)))
-
-(defcomponent standard-display-component ()
-  ((context :accessor context :initarg :context)
-   (object :accessor object :initarg :object)
-   (args :accessor args :initarg :args)))
-
-(defmethod render ((self standard-display-component))
-  
-  (apply #'display self (object self) (args self)))
-
-
 ;;;; * Object displays.
 
-;;;; We like to have a label for attributes, and meta-model provides a default.
-(defdisplay ((desc (eql 'label)) label)
-  (<:span
-   :class "label"
-   (<:as-html label)))
+
 
 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
 
@@ -58,6 +42,9 @@
 (defdisplay (description (object string))
   (<:as-html object))
 
+(defdisplay (description (object symbol))
+  (<:as-html object))
+
 (defdisplay (description object (component t))
   "The default display for CLOS objects"
   (print (class-name (class-of object)))
@@ -89,19 +76,23 @@
 
 (defdisplay (description object)
  (<:div
-  :class "lol-display"	    
+  :class "lol-display"
+  (when (label description)
+    (<:span
+     :class "title"
+     (<:as-html (label description))))
   (do-attributes (attribute description)
     (<:div
-     :class "lol-attribute-row"
+     :class "attribute"
      (display-attribute attribute object)))))
 
 ;;;; ** One line
 (defdisplay
-    :in-layer one-line (description object) 
-    "The one line presentation just displays the attributes with a #\Space between them"
-    (do-attributes (attribute description)
-      (display-attribute attribute object)
-      (<:as-html " ")))
+  :in-layer one-line (description object) 
+  "The one line presentation just displays the attributes with a #\Space between them"
+  (do-attributes (attribute description)
+    (display-attribute attribute object)
+    (<:as-html " ")))
  
 ;;;; ** as-table
 
@@ -113,19 +104,45 @@
       (<:td (display-attribute a object))))))
 
 ;;;; List Displays
+
+(deflayer list-display-layer)
+
+(define-layered-class description
+  :in-layer list-display-layer ()
+  ((list-item :initarg :list-item
+	      :initarg :table-item
+	      :initform nil
+	      :special t
+	      :accessor list-item)))
+
 (defdisplay (desc (list list))
-  (<:ul
-   (dolist* (item list)
-     (<:li  (display* item)
-	    (<:as-html item)))))
+ (with-active-layers (list-display-layer)
+   (<:ul
+    (dolist* (item list)
+      (<:li  (apply #'display* item (list-item desc)))))))
+
+(defdisplay :in-layer as-table (description (list list))
+  (with-active-layers (list-display-layer)
+    (let ((item-description (find-occurence (first list))))
+      (<:table
+	(funcall
+	 (apply #'lol::make-display-function self (first list)
+		(list-item description))
+	 (lambda (desc item component)
+	   (<:tr
+	    (do-attributes (a desc)
+	      (<:th (<:as-html (label a)))))
+	   
+	   (dolist* (obj list)
+	     (<:tr 
+	      (do-attributes (a desc)
+		(<:td (display-attribute a obj)))))))))))
 
 ;;;; Attributes 
 (defdisplay
     :in-layer editor
     ((attribute standard-attribute) object)
-    "Legacy editor using UCW presentations"
-    
-    (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
+    (call-next-method))
 
 (define-layered-method display-using-description
   ((attribute standard-attribute) object component)