r5176: *** empty log message ***

[hyperobject.git] / views.lisp

diff --git a/views.lisp b/views.lisp
index 836a43cac97bd011fee9942fb96557f28ee927e5..c2c71d734edd76677aecc848b114f616126427bc 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.55 2003/06/17 04:56:02 kevin Exp $
+;;;; $Id: views.lisp,v 1.58 2003/06/23 20:08:06 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -55,6 +55,14 @@
                   :accessor obj-end-printer)
    (obj-end-indent :initform nil :initarg :obj-end-indent
                   :accessor obj-end-indent)
+   (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
+                    :accessor subobj-start-printer)
+   (subobj-start-indent :initform nil :initarg :subobj-start-indent
+                    :accessor subobj-start-indent)
+   (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
+                  :accessor subobj-end-printer)
+   (subobj-end-indent :initform nil :initarg :subobj-end-indent
+                  :accessor subobj-end-indent)
    (obj-data-indent :initform nil :initarg :obj-data-indent
                    :accessor obj-data-indent)
    (obj-data-printer :type (or function null) :initform nil
@@ -63,9 +71,15 @@
    (obj-data-print-code :type (or function null) :initform nil
                  :initarg :obj-data-print-code
                  :accessor obj-data-print-code)
-   (obj-data-end-str :type (or string null) :initform nil
-                       :initarg :obj-data-end-str
-                       :accessor obj-data-end-str)
+   (obj-data-start-printer :type (or function string null) :initform nil
+                    :initarg :obj-data-start-printer
+                    :accessor obj-data-start-printer)
+   (obj-data-end-printer :type (or string null) :initform nil
+                       :initarg :obj-data-end-printer
+                       :accessor obj-data-end-printer)
+   (indenter :type (or function null) :initform nil
+            :accessor indenter
+            :documentation "Function that performs hierarchical indenting")
    (link-slots :type list :initform nil
               :documentation "List of slot names that have hyperlinks"
               :accessor link-slots)
@@ -154,7 +168,7 @@
 (defun initialize-view-by-source-code (obj-cl view)
   "Initialize a view based upon a source code"
   (let ((source-code (source-code view)))
-    (error "not implemented")
+    (warn "source code compilation is not implemented")
     )
   )
 
@@ -162,9 +176,8 @@
   `(typecase ,v
     (string
      (write-string ,v ,s))
-    #+allegro
     (fixnum
-     (excl::print-fixnum ,s 10 ,v)) 
+     (write-fixnum ,v ,s))
     (symbol
      (write-string (symbol-name ,v) ,s))
     (t
@@ -304,7 +317,8 @@
              :xhtml :xhtml-labels :xhtml-link-labels
              :xhtml-link :html-link
              :xml :xml-labels :xml-link :ie-xml-link
-             :xml-link-labels :ie-xml-link-labels)
+             :xml-link-labels :ie-xml-link-labels
+             :display-table :edit-table)
     (error "Unknown view category ~A" (category view)))
   
   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
@@ -343,8 +357,10 @@
   (case (category view)
     ((or :compact-text :compact-text-labels)
      (initialize-text-view view))
-    ((or :html :xhtml :html-labels :xhtml-labels)
+    ((or :html :html-labels)
      (initialize-html-view view))
+    ((or :xhtml :xhtml-labels)
+     (initialize-xhtml-view view))
     ((or :xml :xml-labels)
      (initialize-xml-view view))
     ((or :html-link :html-link-labels)
@@ -353,7 +369,7 @@
      (setf (link-href-end view) "a")
      (setf (link-ampersand view) "&"))
     ((or :xhtml-link :xhtml-link-labels)
-     (initialize-html-view view)
+     (initialize-xhtml-view view)
      (setf (link-href-start view) "a href=")
      (setf (link-href-end view) "a")
      (setf (link-ampersand view) "&"))
@@ -370,6 +386,12 @@
      (setf (link-ampersand view) "&"))))
 
 
+(defun make-std-object-slots-view (class-name slots)
+  #'(lambda (obj strm)
+      )
+    
+  )
+
 ;;;; *************************************************************************
 ;;;;  View Data Format Section
 ;;;; *************************************************************************
@@ -389,48 +411,69 @@
 (defun initialize-text-view (view)
   (setf (list-start-printer view)
        (compile nil
-                (eval '(lambda (obj nitems strm)
+                (eval '(lambda (obj nitems indent strm)
+                        (declare (ignore indent))
                         (write-user-name-maybe-plural obj nitems strm)
                         (write-char #\: strm)
                         (write-char #\Newline strm)))))
   (setf (list-start-indent view) t)
   (setf (obj-data-indent view) t)
-  (setf (obj-data-end-str view) +newline-string+))
+  (setf (obj-data-end-printer view) +newline-string+)
+  (setf (indenter view) #'indent-spaces))
 
-(defun html-list-start-func (obj nitems strm)
-  (write-string "<div class=\"ho-username\">" strm)
+(defun html-list-start-func (obj nitems indent strm)
+  (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
   (write-user-name-maybe-plural obj nitems strm)
-  (write-string "</div><div class=\"" strm)
-  (write-string (class-name-of obj) strm)
-  (write-string "\"><ul>" strm)
+  (write-string "</div>" strm)
+  (write-char #\newline strm)
+  (write-string "<ul>" strm)
   (write-char #\newline strm))
 
 (defun initialize-html-view (view)
   (initialize-text-view view)
+  (setf (indenter view) #'indent-spaces)
   (setf (file-start-str view) (format nil "<html><body>~%"))
   (setf (file-end-str view) (format nil "</body><html>~%"))
   (setf (list-start-indent view) t)
   (setf (list-start-printer view) #'html-list-start-func)
-  (setf (list-end-printer view) (format nil "</ul></div>~%"))
+  (setf (list-end-printer view) (format nil "</ul>~%"))
   (setf (list-end-indent view) t)
-  (setf (obj-start-indent view) t)
+  (setf (obj-start-indent view) nil)
   (setf (obj-start-printer view) "<li>")
-  (setf (obj-end-indent view)  t)
+  (setf (obj-end-indent view)  nil)
   (setf (obj-end-printer view)  (format nil "</li>~%"))
+  (setf (obj-data-end-printer view) nil)
   (setf (obj-data-indent view) nil))
 
+(defun xhtml-list-start-func (obj nitems indent strm)
+  (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
+  (write-user-name-maybe-plural obj nitems strm)
+  (write-string "</div>" strm)
+  (write-string "<div :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
+  (write-char #\newline strm))
+
+(defun html-obj-start (obj indent strm)
+  (declare (ignore obj indent))
+  (write-string "<div style=\"margin-left:2em;\">" strm))
+
 (defun initialize-xhtml-view (view)
   (initialize-text-view view)
+  (setf (indenter view) #'indent-spaces)
   (setf (file-start-str view) (format nil "<html><body>~%"))
   (setf (file-end-str view) (format nil "</body><html>~%"))
-  (setf (list-start-indent view) t)
-  (setf (list-start-printer view) #'html-list-start-func)
-  (setf (list-end-printer view) (format nil "</ul></div>~%"))
-  (setf (list-end-indent view) t)
-  (setf (obj-start-indent view) t)
-  (setf (obj-start-printer view) "<li>")
-  (setf (obj-end-indent view)  t)
-  (setf (obj-end-printer view) (format nil "</li>~%"))
+  (setf (list-start-indent view) nil)
+  (setf (list-start-printer view) #'xhtml-list-start-func)
+  (setf (list-end-printer view) (format nil "</div>~%"))
+  (setf (list-end-indent view) nil)
+  (setf (obj-start-indent view) nil)
+  (setf (obj-start-printer view) #'html-obj-start)
+  (setf (obj-end-printer view) (format nil "</div>~%"))
   (setf (obj-data-indent view) nil))
 
 (defun xmlformat-list-end-func (x strm)
@@ -440,7 +483,8 @@
   (write-string ">" strm)
   (write-char #\newline strm))
 
-(defun xmlformat-list-start-func (x nitems strm)
+(defun xmlformat-list-start-func (x nitems indent strm)
+  (declare (ignore indent))
   (write-char #\< strm)
   (write-string (class-name-of x) strm)
   (write-string "list><title>" strm)
@@ -457,8 +501,8 @@
   (setf (list-end-printer view) #'xmlformat-list-end-func)
   (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view)))
   (setf (obj-start-indent view) t)
-  (setf (obj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
-  (setf (obj-end-indent view) nil)
+  (setf (subobj-end-printer view) (format nil "</~(~a~)>" (object-class-name view)))
+  (setf (subobj-end-indent view) nil)
   (setf (obj-data-indent view) nil))
 
 
@@ -476,16 +520,18 @@
 
 (defun fmt-list-start (obj view strm indent num-items)
   (when (list-start-indent view)
-    (indent-spaces indent strm))
+    (awhen (indenter view)
+          (funcall it indent strm)))
   (awhen (list-start-printer view)
         (if (stringp it)
             (write-string it strm)
-            (funcall it obj num-items strm))))
+            (funcall it obj num-items indent strm))))
 
 (defun fmt-list-end (obj view strm indent num-items)
   (declare (ignore num-items))
   (when (list-end-indent view)
-      (indent-spaces indent strm))
+    (awhen (indenter view)
+          (funcall it indent strm)))
   (awhen (list-end-printer view)
         (if (stringp it)
             (write-string it strm)
@@ -493,21 +539,42 @@
 
 ;;; Object Start and Ends
 
+
 (defun fmt-obj-start (obj view strm indent)
   (when (obj-start-indent view)
-    (indent-spaces indent strm))
+    (awhen (indenter view)
+          (funcall it indent strm)))
   (awhen (obj-start-printer view)
         (if (stringp it)
             (write-string it strm)
-            (funcall it obj strm))))
+            (funcall it obj indent strm))))
 
 (defun fmt-obj-end (obj view strm indent)
   (when (obj-end-indent view)
-    (indent-spaces indent strm))
+    (awhen (indenter view)
+          (funcall it indent strm))) 
   (awhen (obj-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))
+
+(defun fmt-subobj-start (obj view strm indent)
+  (when (subobj-start-indent view)
+    (awhen (indenter view)
+          (funcall it indent strm)))
+  (awhen (subobj-start-printer view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj indent strm))))
+
+(defun fmt-subobj-end (obj view strm indent)
+  (when (subobj-end-indent view)
+    (awhen (indenter view)
+          (funcall it indent strm))) 
+  (awhen (subobj-end-printer view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm))))
   
 ;;; Object Data 
 
@@ -539,13 +606,20 @@
   (link-href-end view))
 
 (defun fmt-obj-data (obj view strm indent refvars link-printer)
+  (awhen (obj-data-start-printer view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm)))
   (when (obj-data-indent view)
-    (indent-spaces indent strm))
+    (awhen (indenter view)
+          (funcall it indent strm)))
   (if (link-slots view)
       (fmt-obj-data-with-link obj view strm refvars link-printer)
       (fmt-obj-data-plain obj view strm))
-  (awhen (obj-data-end-str view)
-        (write-string it strm)))
+  (awhen (obj-data-end-printer view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm))))
 
 (defun fmt-obj-data-plain (obj view strm)
   (awhen (obj-data-printer view)
@@ -595,6 +669,8 @@
         (unless (and filter (not (funcall filter obj)))
           (fmt-obj-start obj view strm indent)
           (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
+          (fmt-obj-end obj view strm indent)
+          (fmt-subobj-start obj view strm indent)
           (when (and subobjects (hyperobject-class-subobjects obj))
            (dolist (subobj (hyperobject-class-subobjects obj))
              (aif (slot-value obj (name-slot subobj))
@@ -603,7 +679,7 @@
                                                        category)
                                     category strm (1+ indent) filter
                                     subobjects refvars link-printer))))
-         (fmt-obj-end obj view strm indent)))
+         (fmt-subobj-end obj view strm indent)))
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)