Moved description details out of display.

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

diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index eff4d4e..4542618 100644 (file)
--- a/src/standard-descriptions/t.lisp
+++ b/src/standard-descriptions/t.lisp
@@ -2,46 +2,81 @@
 
 (define-description T ()
   ((identity :label nil :function #'identity)
-   (type :label "Type of" :function #'type-of)
+   (type :label "Type" :function #'type-of)
    (class :label "Class" :function #'class-of)
    (active-attributes :label "Attributes"
                      :value nil
                      :activep nil
-                     :keyword :attributes)))
+                     :keyword :attributes)
+   (attribute-delimiter :label "Attribute Delimiter"
+                       :value "~%"
+                       :activep nil
+                       :keyword :delimter)
+   (active-descriptions :label "Active Descriptions"
+                       :value nil
+                       :activep nil
+                       :keyword :activate)
+   (inactive-descriptions :label "Inactive Descriptions"
+                       :value nil
+                       :activep nil
+                       :keyword :deactivate)
+   (label-formatter :value (lambda (label)
+                            (generic-format *display* "~A:" label))
+                   :activep nil)
+   (value-formatter :value (curry #'format nil "~A")
+                   :activep nil)))
 
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))
 
-(define-layered-function display-attribute (object attribute)
-  (:method (object attribute)
-    (display-using-description attribute *display* object)))
+(define-layered-function display-attribute (attribute)
+  (:method (attribute)
+    (display-using-description attribute *display* (attribute-object attribute))))
 
-(define-layered-function display-attribute-label (object attribute)
-  (:method (object attribute)
-        (format *display* "~A " (attribute-label attribute))))
+(define-layered-function display-attribute-label (attribute)
+  (:method (attribute)
+    (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
+          
 
-(define-layered-function display-attribute-value (object attribute)
-  (:method (object attribute)
+
+(define-layered-function display-attribute-value (attribute)
+  (:method (attribute)
+    (flet ((disp (val &rest args)
+            (apply #'display *display* val 
+                   :activate (attribute-active-descriptions attribute)
+                   :deactivate (attribute-inactive-descriptions attribute)
+                   args)))
+            
     (let ((val (attribute-value attribute)))
-      (if (eql val object)
-         (format *display* "~A " val)
+      (if (eql val (attribute-object attribute))
+         (generic-format *display* (funcall (attribute-value-formatter attribute) val))
          (with-active-descriptions (inline)
-           (display *display* val))))))
+           (if (slot-boundp attribute 'active-attributes)
+               (disp val :attributes (slot-value attribute 'active-attributes))
+               (disp val))))))))
 
 (define-layered-method display-using-description 
   ((attribute standard-attribute) display object &rest args)
   (declare (ignore args))
   (when (attribute-label attribute)
-    (display-attribute-label object attribute))
-  (display-attribute-value object attribute))
+    (display-attribute-label attribute))
+  (display-attribute-value attribute))
 
 (define-display ((description t))
-  (format *display* "~{~A~%~}" 
-         (mapcar 
-          (lambda (attribute)
-            (with-output-to-string (*display*)
-              (display-attribute *object* attribute)))
-          (attributes description))))
+ (let ((attributes (attributes description)))
+   (display-attribute (first attributes))
+   (dolist (attribute (rest attributes) (values))
+     (generic-format *display* 
+      (attribute-value 
+       (find-attribute description 'attribute-delimiter)))
+     (display-attribute attribute))))
+  
+
+(define-display :around ((description t) (display null) object)
+ (with-output-to-string (*standard-output*)
+   (call-next-layered-method description t object))
+)              
+