Massive patch to compile with modern versions of the libraries. This is only 1/2...

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

diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index a5b0f0e..041541d 100644 (file)
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -4,56 +4,60 @@
 (deflayer viewer)
 (deflayer editor)
 
+;;;; Attributes 
+(defdisplay
+    :in-layer editor
+    ((attribute standard-attribute) object)
+    (call-next-method))
+
+(defdisplay
+  ((attribute standard-attribute) object component)
+ (<:as-html (attribute-value object attribute)))
+
+(define-layered-method display-using-description
+  ((attribute standard-attribute) object component)
+  (with-component (component)
+    )
+  (<:as-html (attribute-value object attribute)))
+
+(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)))
+  "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)))
 
-(deflayer creator)
+;;;; These layers affect the layout of the object
 (deflayer one-line)
 (deflayer as-table)
+(deflayer as-string)
 
+(defdisplay
+  :in-layer as-string (d o (self t))
+  (with-output-to-string (yaclml::*yaclml-stream*)
+    (do-attributes (a d)
+      (display-attribute a o)
+      (<:as-html " "))
+    #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+)))
 
 
-(deflayer as-string)
-
 (defdisplay
   :in-layer as-string (d o)
-  (with-inactive-layers (editor viewer creator one-line as-table label-attributes)
+  (with-output-to-string (yaclml::*yaclml-stream*)
     (do-attributes (a d)
       (display-attribute a o)
-      (<:as-is " "))))
+      (<:as-html " "))
+    #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+)))
 
 (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.
 
 
@@ -66,11 +70,13 @@ This allows us to dispatch to a subclasses editor."
 (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)))
   (dolist* (slot-name (list-slots object))
-  
     (let ((boundp (slot-boundp object slot-name)))
       (format t "~A~A : ~A" (strcat slot-name)
              (if boundp
@@ -109,11 +115,11 @@ This allows us to dispatch to a subclasses editor."
 
 ;;;; ** 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
 
@@ -125,26 +131,41 @@ This allows us to dispatch to a subclasses editor."
       (<: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)))
 
-(define-layered-method display-using-description
-  ((attribute standard-attribute) object component)
-  (with-component (component)
-    (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
-           (<:as-html "*" )))
-  (<:as-html (attribute-value object attribute)))