r4920: Auto commit for Debian build
[hyperobject.git] / views.lisp
index a80c1e9a58051331c17fae8530096be424fd0241..f44f800ac352f93834959b600ef07459ea581d8e 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.11 2002/12/09 10:39:38 kevin Exp $
+;;;; $Id: views.lisp,v 1.33 2003/05/14 04:28:09 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
   (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 
+(defclass object-view ()
+  ((object-class-name :initform nil :initarg :object-class-name
+                     :accessor object-class-name
+                :documentation "Name of class of object to be viewed.")
+   (object-class :initform nil :initarg :object-class
+                :accessor object-class
+                :documentation "Class of object to be viewed.")
+   (slots :initform nil :initarg :slots :accessor slots
+         :documentation "List of effective slots for object to be viewed.")
+   (name :initform nil :initarg :name :accessor name
+        :documentation "Name for this view.")
+   (category :initform nil :initarg :category :accessor category
+            :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
+   (source-code :initform nil :initarg :source-code :accessor source-code 
+               :documentation "Source code for generating view.")
+   (country-language :initform :en :initarg :country-language
+                    :documentation "Country's Language for this view.")
+   ;;
+   (file-start-str :type (or string null) :initform nil :initarg :file-start-str
+                  :accessor file-start-str)
+   (file-end-str :type (or string null) :initform nil :initarg :file-end-str
+                :accessor file-end-str)
+   (list-start-str-or-func :type (or string function null) :initform nil
+                          :initarg :list-start-str-or-func
+                     :accessor list-start-str-or-func)
+   (list-start-indent :initform nil :initarg :list-start-indent
+                     :accessor list-start-indent)
+   (list-end-str-or-func :type (or string function null) :initform nil
+                        :initarg :list-end-str-or-func
+                   :accessor list-end-str-or-func)
+   (list-end-indent :initform nil :initarg :list-end-indent
+                   :accessor list-end-indent)
+   (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func
+                    :accessor obj-start-str-or-func)
+   (obj-start-indent :initform nil :initarg :obj-start-indent
+                    :accessor obj-start-indent)
+   (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func
+                  :accessor obj-end-str-or-func)
+   (obj-end-indent :initform nil :initarg :obj-end-indent
+                  :accessor obj-end-indent)
+   (obj-data-indent :initform nil :initarg :obj-data-indent
+                   :accessor obj-data-indent)
+   (obj-data-func :type (or function null) :initform nil
+                       :initarg :obj-data-func
+                       :accessor obj-data-func)
+   (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)
+   (link-slots :type list :initform nil
+              :documentation "List of slot names that have hyperlinks"
+              :accessor link-slots)
+   (link-page-name :type (or string null) :initform nil :initarg :link-page-name
+                  :accessor link-page-name)
+   (link-href-start :type (or string null) :initform nil :initarg :link-href-start
+                   :accessor link-href-start)
+   (link-href-end :type (or string null) :initform nil :initarg :link-href-end
+                 :accessor link-href-end)
+   (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
+                  :accessor link-ampersand))
+  (:default-initargs :link-page-name "disp-func1")
+  (:documentation "View class for a hyperobject"))
+
+
+(defun get-category-view (obj category &optional slots)
+  "Find or make a category view for an object"
+  (let ((obj-class (class-of obj)))
+    (if (null category)
+       (default-view obj-class)
+       (aif (find category (views obj-class) :key #'category)
+            it
+            (let ((view
+                   (make-instance 'object-view
+                                  :object-class-name (class-name obj-class)
+                                  :object-class obj-class
+                                  :category category
+                                  :slots slots)))
+              (push view (views obj-class))
+              view)))))
+                            
 ;;;; *************************************************************************
 ;;;;  Metaclass Intialization
 ;;;; *************************************************************************
 
-(defun finalize-hyperlinks (cl)
-  (let ((hyperlinks '()))
-    (dolist (esd (class-slots cl))
-      (awhen (slot-value esd 'hyperlink)
-        (push
-        (make-instance 'hyperlink
-                       :name (slot-definition-name esd)
-                       :lookup it
-                       :link-parameters (slot-value esd 'hyperlink-parameters))
-        hyperlinks)))
-    (setf (slot-value cl 'hyperlinks) hyperlinks)))
-
-
 (defun finalize-views (cl)
+  "Finalize all views that are given on a objects initialization"
+  (unless (default-print-slots cl)
+    (setf (default-print-slots cl)
+         (mapcar #'slot-definition-name (class-slots cl))))
+  (let ((views '()))
+    (dolist (view-def (views cl))
+      (push (make-object-view cl view-def) views))
+    (setf (views cl) (nreverse views)))
+  (cond
+    ((default-view cl)
+     (setf (default-view cl) (make-object-view cl (default-view cl))))
+    ((car (views cl))
+     (setf (default-view cl) (make-object-view cl (car (views cl)))))
+    (t
+     (setf (default-view cl) (make-object-view cl :default)))))
+
+(defun make-object-view (cl view-def)
+  "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
+  (cond
+    ((typep view-def 'object-view)
+     view-def)
+    ((eq view-def :default)
+     (let* ((name (class-name cl))
+           (view (make-instance 'object-view :name "automatic"
+                                :object-class-name name
+                                :object-class cl
+                                :category :compact-text)))
+       view))
+    ((consp view-def)
+     (eval `(make-instance ,view-def)))
+    (t
+     (error "Invalid parameter to make-object-view: ~S" view-def))))
+
+(defmethod initialize-instance :after ((view object-view)
+                                      &rest initargs &key &allow-other-keys)
+  (initialize-view (object-class view) view))
+  
+(defun initialize-view (obj-cl view)
   "Calculate all view slots for a hyperobject class"
-  (let ((fmtstr-text "")
-       (fmtstr-html "")
-       (fmtstr-xml "")
-       (fmtstr-text-labels "")
-       (fmtstr-html-labels "")
-       (fmtstr-xml-labels "")
-       (fmtstr-html-ref "")
-       (fmtstr-xml-ref "")
-       (fmtstr-html-ref-labels "")
-       (fmtstr-xml-ref-labels "")
+  (cond
+    ((category view)
+     (initialize-view-by-category obj-cl view))
+    ((source-code view)
+     (initialize-view-by-source-code obj-cl view))
+    (t
+     (setf (category view) :compact-text)
+     (initialize-view-by-category obj-cl view))))
+
+(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")
+    )
+  )
+
+
+(defun write-ho-value (obj name type formatter cdata strm)
+  (declare (ignorable type))
+  (let* ((slot-data (slot-value obj name))
+        (fmt-data (if formatter
+                      (funcall formatter slot-data)
+                  slot-data))
+        (data (if cdata
+                  (kmrcl:xml-cdata fmt-data)
+                  fmt-data)))
+    (typecase data
+      (string
+       (write-string data strm))
+      (number
+       (write-string (write-to-string data) strm))
+      (t
+       (format strm "~A" data)))))
+
+(defun ppfc-html (title name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<span class=\"" s) print-func)
+  (vector-push-extend `(write-string ,title s) print-func)
+  (vector-push-extend '(write-string "\">" s) print-func)
+  (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+  (vector-push-extend '(write-string "</span>" s) print-func))
+
+(defun ppfc-xml (tag name type formatter cdata print-func)
+  (vector-push-extend '(write-char #\< s) print-func)
+  (vector-push-extend `(write-string ,tag s) print-func)
+  (vector-push-extend '(write-char #\> s) print-func)
+  (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+  (vector-push-extend '(write-string "</" s) print-func)
+  (vector-push-extend `(write-string ,tag s) print-func)
+  (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-labels (label name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</span> " s) print-func)
+  (ppfc-html label name type formatter cdata print-func))
+
+(defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</span> " s) print-func)
+  (ppfc-html tag name type formatter cdata print-func))
+
+(defun ppfc-xml-labels (label tag name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<label>" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</label> " s) print-func)
+  (ppfc-xml tag name type formatter cdata print-func))
+
+(defun ppfc-html-link (name type formatter cdata nlink print-func)
+  (vector-push-extend '(write-char #\< s) print-func)
+  (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) 
+  (vector-push-extend '(write-char #\> s) print-func)
+  (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+  (vector-push-extend '(write-string "</" s) print-func)
+  (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func) 
+  (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
+  (vector-push-extend '(write-string "<label>" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</label> " s) print-func)
+  (ppfc-html-link name type formatter cdata nlink print-func))
+
+(defun push-print-fun-code (category slot nlink print-func)
+  (let* ((formatter (esd-print-formatter slot))
+        (name (slot-definition-name slot))
+        (namestr-lower (string-downcase (symbol-name name)))
+        (xml-namestr (escape-xml-string namestr-lower))
+        (xml-tag (escape-xml-string namestr-lower))
+        (type (slot-value slot 'type))
+        (cdata (not (null
+                     (and (in category :xml :xhtml :xml-link :xhtml-link
+                              :xml-labels :ie-xml-labels
+                              :xhtml-link-labels :xml-link-labels :ie-xml-link
+                              :ie-xml-link-labels)
+                          (or formatter
+                              (lisp-type-is-a-string type))))))
+        (hyperlink (esd-hyperlink slot)))
+    
+    (case category
+      (:compact-text
+       (vector-push-extend
+       `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+      (:compact-text-labels
+       (vector-push-extend `(write-string ,namestr-lower s) print-func)
+       (vector-push-extend '(write-char #\space s) print-func)
+       (vector-push-extend
+       `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+      ((or :html :xhtml)
+       (ppfc-html namestr-lower name type formatter cdata print-func))
+      (:xml
+       (ppfc-xml xml-tag name type formatter cdata print-func))
+      (:html-labels
+       (ppfc-html-labels namestr-lower name type formatter cdata print-func))
+      (:xhtml-labels
+       (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func))
+      (:xml-labels
+       (ppfc-xml-labels xml-namestr xml-tag name type formatter cdata print-func))
+      ((or :html-link :xhtml-link)
+       (if hyperlink
+          (ppfc-html-link name type formatter cdata nlink print-func)
+          (ppfc-html namestr-lower name type formatter cdata print-func)))
+      ((or :xml-link :ie-xml-link)
+       (if hyperlink
+          (ppfc-html-link name type formatter cdata nlink print-func)
+          (ppfc-xml xml-tag name type formatter cdata print-func)))
+      (:html-link-labels
+       (if hyperlink
+          (ppfc-html-labels namestr-lower name type formatter cdata print-func)))
+      (:xhtml-link-labels
+       (if hyperlink
+          (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+                                 print-func)
+          (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata
+                             print-func)))
+      ((or :xml-link-labels :ie-xml-link-labels)
+       (if hyperlink
+          (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+                                 print-func)
+          (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata
+                           print-func))))))
+
+
+(defun view-has-links-p (view)
+  (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
+      :html-link-labels :xhtml-links-labels :xml-link-labels
+      :ie-xml-link-labels))
+
+(defun initialize-view-by-category (obj-cl view)
+  "Initialize a view based upon a preset category"
+  (unless (in (category view) :compact-text :compact-text-labels
+             :html :html-labels :html-link-labels
+             :xhtml :xhtml-labels :xhtml-link-labels
+             :xml :xml-labels :xml-link :ie-xml-link
+             :xml-link-labels :ie-xml-link-labels)
+    (error "Unknown view category ~A" (category view)))
+  
+  (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
+
+  (let ((links '())
+       (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
+
+    (do* ((slots (slots view) (cdr slots))
+         (slot-name (car slots) (car slots))
+         (slot (find-slot-by-name obj-cl slot-name)
+               (find-slot-by-name obj-cl slot-name)))
+        ((null slots))
+      (unless slot
+       (error "Slot ~A is not found in class ~S" slot-name obj-cl))
+      
+      (push-print-fun-code (category view) slot (length links) print-func)
+      (when (> (length slots) 1)
+       (vector-push-extend '(write-char #\space s) print-func))
+
+      (when (and (view-has-links-p view) (esd-hyperlink slot))
+       (push (slot-definition-name slot) links)))
+
+    (setf (obj-data-print-code view) `(lambda (x s links)
+                                      (declare (ignorable links))
+                                      ,@(map 'list #'identity print-func)))
+    
+    (setf (obj-data-func view)
+         (when print-func (compile nil (eval (obj-data-print-code view)))))
+    
+    (setf (link-slots view) (nreverse links)))
+
+  (finalize-view-by-category view)
+  view)
+
+(defun finalize-view-by-category (view)
+  (case (category view)
+    ((or :compact-text :compact-text-labels)
+     (initialize-text-view view))
+    ((or :html :xhtml :html-labels :xhtml-labels)
+     (initialize-html-view view))
+    ((or :xml :xml-labels)
+     (initialize-xml-view view))
+    ((or :html-link :html-link-labels)
+     (initialize-html-view view)
+     (setf (link-href-start view) "a href=")
+     (setf (link-href-end view) "a")
+     (setf (link-ampersand view) "&"))
+    ((or :xhtml-link :xhtml-link-labels)
+     (initialize-html-view view)
+     (setf (link-href-start view) "a href=")
+     (setf (link-href-end view) "a")
+     (setf (link-ampersand view) "&amp;"))
+    ((or :xml-link :xml-link-labels)
+     (initialize-xml-view view)
+     (setf (link-href-start view)
+          "xmllink xlink:type=\"simple\" xlink:href=")
+     (setf (link-href-end view) "xmllink")
+     (setf (link-ampersand view) "&amp;"))
+    ((or :ie-xml-link :ie-xml-link-labels)
+     (initialize-xml-view view)
+     (setf (link-href-start view) "html:a href=")
+     (setf (link-href-end view) "html:a")
+     (setf (link-ampersand view) "&amp;"))))
+
+#+ignore
+(defun initialize-view-by-category (obj-cl view)
+  "Initialize a view based upon a preset category"
+  (let ((fmtstr nil)
        (first-field t)
        (value-func '())
-       (xmlvalue-func '())
-       (classname (class-name cl))
-       (package (symbol-package (class-name cl)))
-       (hyperlinks nil))
-    (declare (ignore classname))
-    (check-type (slot-value cl 'print-slots) list)
-    (dolist (slot-name (slot-value cl 'print-slots))
-      (let ((slot (find-slot-by-name cl slot-name)))
+       (links '())
+       (category (category view)))
+
+    (unless (in category :compact-text :compact-text-labels
+               :html :html-labels :html-link-labels
+               :xhtml :xhtml-labels :xhtml-link-labels
+               :xml :xml-labels :xml-link :ie-xml-link
+               :xml-link-labels :ie-xml-link-labels)
+      (error "Unknown view category ~A" category))
+    
+    (unless (slots view)
+      (setf (slots view) (default-print-slots obj-cl)))
+    (dolist (slot-name (slots view))
+      (let ((slot (find-slot-by-name obj-cl slot-name)))
        (unless slot
-         (error "Slot ~A is not found in class ~S" slot-name cl))
-       (let ((name (slot-definition-name slot))
-             (namestr (symbol-name (slot-definition-name slot)))
-             (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
-             (type (slot-value slot 'ho-type))
-             (print-formatter (slot-value slot 'print-formatter))
-             (value-fmt "~a")
-             (plain-value-func nil)
-             html-str xml-str html-label-str xml-label-str)
-         
-         (when (or (eql type :integer) (eql type :fixnum))
-           (setq value-fmt "~d"))
-         
-         (when (eql type :boolean)
-           (setq value-fmt "~a"))
-         
-         (if first-field
-             (setq first-field nil)
-             (progn
-               (string-append fmtstr-text " ")
-               (string-append fmtstr-html " ")
-               (string-append fmtstr-xml " ")
-               (string-append fmtstr-text-labels " ")
-               (string-append fmtstr-html-labels " ")
-               (string-append fmtstr-xml-labels " ")
-               (string-append fmtstr-html-ref " ")
-               (string-append fmtstr-xml-ref " ")
-               (string-append fmtstr-html-ref-labels " ")
-               (string-append fmtstr-xml-ref-labels " ")))
-         
-         (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
-         (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-         (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
-         (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-         
-         (string-append fmtstr-text value-fmt)
-         (string-append fmtstr-html html-str)
-         (string-append fmtstr-xml xml-str)
-         (string-append fmtstr-text-labels namestr-lower " " value-fmt)
-         (string-append fmtstr-html-labels html-label-str)
-         (string-append fmtstr-xml-labels xml-label-str)
-         
-         (if (slot-value slot 'hyperlink)
-             (progn
-               (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
-               (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
-               (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
-               (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
-               (push (make-instance 'hyperlink :name name
-                                    :lookup (slot-value slot 'hyperlink))
-                     hyperlinks))
-             (progn
-               (string-append fmtstr-html-ref html-str)
-               (string-append fmtstr-xml-ref xml-str)
-               (string-append fmtstr-html-ref-labels html-label-str)
-               (string-append fmtstr-xml-ref-labels xml-label-str)))
-         
-         (if print-formatter
-             (setq plain-value-func 
-                   (list `(,print-formatter (slot-value x ',(intern namestr package)))))
-             (setq plain-value-func 
-                   (list `(slot-value x ',(intern namestr package)))))
-         (setq value-func (append value-func plain-value-func))
-         
-         (if (eql type :cdata)
-             (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
-             (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+         (error "Slot ~A is not found in class ~S" slot-name obj-cl))
+       (let* ((name (slot-definition-name slot))
+              (namestr-lower (string-downcase (symbol-name name)))
+              (xml-namestr (escape-xml-string namestr-lower))
+              (xml-tag (escape-xml-string namestr-lower))
+              (type (slot-value slot 'type))
+              (print-formatter (esd-print-formatter slot)))
+
+         (cond
+           (first-field
+            (setq fmtstr "")
+            (setq first-field nil))
+           (t
+            (string-append fmtstr " ")))
+
+         (let ((value-fmt
+                (case type
+                  ((or :integer :fixnum)
+                   "~d")
+                  (:boolean
+                   "~a")
+                  (otherwise
+                   "~a"))))
+           (case category
+             (:compact-text
+              (string-append fmtstr value-fmt))
+             (:compact-text-labels
+              (string-append fmtstr namestr-lower " " value-fmt))
+             ((or :html :xhtml)
+              (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>")))
+             (:xml
+              (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">")))
+             (:html-labels
+              (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
+             (:xhtml-labels
+              (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
+             (:xml-labels
+              (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))
+             ((or :html-link :xhtml-link)
+              (push name links)
+              (if (esd-hyperlink slot)
+                  (string-append fmtstr "<~~a>" value-fmt "</~~a>")
+                  (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))))
+             ((or :xml-link :ie-xml-link)
+              (push name links)
+              (if (esd-hyperlink slot)
+                  (string-append fmtstr "<~~a>" value-fmt "</~~a>")
+                  (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "</" xml-tag ">"))))
+             (:html-link-labels
+              (push name links)
+              (if (esd-hyperlink slot)
+                  (string-append fmtstr "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
+                  (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
+             (:xhtml-link-labels
+              (push name links)
+              (if (esd-hyperlink slot)
+                  (string-append fmtstr "<span class=\"label\">" xml-namestr "</span> <~~a>" value-fmt "</~~a>")
+                  (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
+             ((or :xml-link-labels :ie-xml-link-labels)
+              (push name links)
+              (if (esd-hyperlink slot)
+                  (string-append fmtstr "<label>" xml-namestr "</label> <~~a>" value-fmt "</~~a>")
+                  (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))))
+           ) ;; let value-fmt
+           
+         (let ((func (if print-formatter
+                 `(,print-formatter (slot-value x (quote ,name)))
+                 `(slot-value x (quote ,name)))))
+           (when (and (in category :xml :xhtml :xml-link :xhtml-link
+                          :xml-labels :ie-xml-labels
+                          :xhtml-link-labels :xml-link-labels :ie-xml-link
+                          :ie-xml-link-labels)
+                      (or print-formatter
+                          (lisp-type-is-a-string type)))
+             (setq func `(kmrcl:xml-cdata ,func)))
+           (push func value-func))
          )))
+         
+    (when value-func
+      (setq value-func
+           (compile nil (eval `(lambda (x) (values ,@(nreverse value-func)))))))
+
+    (setf (obj-data-fmtstr view) fmtstr)
+    (setf (obj-data-value-func view) value-func)
+    (setf (link-slots view) (nreverse links))
     
-    (setf (slot-value cl 'hyperlinks) hyperlinks)
-    
-    (if value-func
-       (setq value-func `(lambda (x) (values ,@value-func)))
-       (setq value-func `(lambda () (values))))
-    (setq value-func (compile nil (eval value-func)))
-    
-    (if xmlvalue-func
-       (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
-       (setq xmlvalue-func `(lambda () (values))))
-    (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
-    
-    (setf (slot-value cl 'fmtstr-text) fmtstr-text)
-    (setf (slot-value cl 'fmtstr-html) fmtstr-html)
-    (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
-    (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
-    (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
-    (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
-    (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
-    (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
-    (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
-    (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
-    (setf (slot-value cl 'value-func) value-func)
-    (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
-  (values))
+    (case category
+      ((or :compact-text :compact-text-labels)
+       (initialize-text-view view))
+      ((or :html :xhtml :html-labels :xhtml-labels)
+       (initialize-html-view view))
+      ((or :xml :xml-labels)
+       (initialize-xml-view view))
+      ((or :html-link :html-link-labels)
+       (initialize-html-view view)
+       (setf (link-href-start view) "a href=")
+       (setf (link-href-end view) "a")
+       (setf (link-ampersand view) "&"))
+      ((or :xhtml-link :xhtml-link-labels)
+       (initialize-html-view view)
+       (setf (link-href-start view) "a href=")
+       (setf (link-href-end view) "a")
+       (setf (link-ampersand view) "&amp;"))
+      ((or :xml-link :xml-link-labels)
+       (initialize-xml-view view)
+       (setf (link-href-start view)
+            "xmllink xlink:type=\"simple\" xlink:href=")
+       (setf (link-href-end view) "xmllink")
+       (setf (link-ampersand view) "&amp;"))
+      ((or :ie-xml-link :ie-xml-link-labels)
+       (initialize-xml-view view)
+       (setf (link-href-start view) "html:a href=")
+       (setf (link-href-end view) "html:a")
+       (setf (link-ampersand view) "&amp;"))))
+  view)
 
 
 ;;;; *************************************************************************
 ;;;;  View Data Format Section
 ;;;; *************************************************************************
 
-(defparameter *default-textformat* nil)
-(defparameter *default-htmlformat* nil)
-(defparameter *default-htmlrefformat* nil)
-(defparameter *default-xhtmlformat* nil)
-(defparameter *default-xhtmlrefformat* nil)
-(defparameter *default-xmlformat* nil)
-(defparameter *default-xmlrefformat* nil)
-(defparameter *default-ie-xmlrefformat* nil)
-(defparameter *default-nullformat* nil)
-(defparameter *default-init-format?* nil)
-
-(defun make-format-instance (fmt)
-  (unless *default-init-format?*
-    (setq *default-textformat* (make-instance 'textformat))
-    (setq *default-htmlformat* (make-instance 'htmlformat))
-    (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
-    (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
-    (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
-    (setq *default-xmlformat* (make-instance 'xmlformat))
-    (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
-    (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
-    (setq *default-nullformat* (make-instance 'nullformat))
-    (setq *default-init-format?* t))
-  
-  (case fmt
-      (:text *default-textformat*)
-      (:html *default-htmlformat*)
-      (:htmlref *default-htmlrefformat*)
-      (:xhtml  *default-xhtmlformat*)
-      (:xhtmlref *default-xhtmlrefformat*)
-      (:xml  *default-xmlformat*)
-      (:xmlref *default-xmlrefformat*)
-      (:ie-xmlref *default-ie-xmlrefformat*)
-      (:null *default-nullformat*)
-      (otherwise *default-textformat*)))
-    
-;;;; Output format classes for print hyperobject-classes
-
-(defclass dataformat ()
-  ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
-   (file-end-str :type string :initarg :file-end-str :reader file-end-str)
-   (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
-   (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
-   (list-start-indent :initarg :list-start-indent :reader list-start-indent)
-   (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
-   (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
-   (list-end-indent :initarg :list-end-indent :reader list-end-indent)
-   (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
-   (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
-   (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
-   (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
-   (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
-   (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
-   (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
-   (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
-   (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
-   (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
-   (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
-   (link-ref :initarg :link-ref :reader link-ref))
-  (:default-initargs :file-start-str nil :file-end-str nil
-                    :list-start-fmtstr nil :list-start-value-func nil
-                    :list-start-indent nil :list-end-fmtstr nil
-                    :list-end-value-func nil :list-end-indent nil
-                    :obj-start-fmtstr nil :obj-start-value-func nil
-                    :obj-start-indent nil :obj-end-fmtstr nil
-                    :obj-end-value-func nil :obj-end-indent nil
-                    :obj-data-indent nil :obj-data-fmtstr nil
-                    :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
-                    :obj-data-value-func nil :link-ref nil)
-  (:documentation "Parent for all dataformat objects"))
-
-(defclass binaryformat (dataformat)
-  ())
-
-(defclass nullformat (dataformat)
-  ())
-
-(defun text-list-start-value-func (obj nitems)
-  (values (hyperobject-class-user-name obj) nitems))
-
-(defclass textformat (dataformat) 
-  ()   
-  (:default-initargs :list-start-fmtstr "~a~P:~%"
-    :list-start-value-func #'text-list-start-value-func
-    :list-start-indent t
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-text
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
-    :obj-data-end-fmtstr "~%"
-    :obj-data-value-func #'hyperobject-class-value-func))
-
-
 (defun class-name-of (obj)
   (string-downcase (class-name (class-of obj))))
 
-(defun htmlformat-list-start-value-func (x nitems) 
-  (values (hyperobject-class-user-name x) nitems (class-name-of x)))
-
-(defclass htmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "<html><body>~%"
-    :file-end-str "</body><html>~%"
-    :list-start-indent t
-    :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
-    :list-start-value-func #'htmlformat-list-start-value-func
-    :list-end-fmtstr "</ul></div>~%"
-    :list-end-indent t
-    :list-end-value-func #'identity
-    :obj-start-indent t
-    :obj-start-fmtstr "<li>"
-    :obj-start-value-func #'identity
-    :obj-end-indent  t
-    :obj-end-fmtstr  "</li>~%"
-    :obj-end-value-func #'identity
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
-    :obj-data-value-func #'hyperobject-class-value-func))
-
-(defclass xhtmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "<html><body>~%"
-    :file-end-str "</body><html>~%"
-    :list-start-indent t
-    :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
-    :list-start-value-func #'htmlformat-list-start-value-func
-    :list-end-fmtstr "</ul></div>~%"
-    :list-end-indent t
-    :list-end-value-func #'identity
-    :obj-start-indent t
-    :obj-start-fmtstr "<li>"
-    :obj-start-value-func #'identity
-    :obj-end-indent  t
-    :obj-end-fmtstr  "</li>~%"
-    :obj-end-value-func #'identity
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
-    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
-
-
-(defun xmlformat-list-end-value-func (x)
-  (format nil "~alist" (class-name-of x)))
-
-(defun xmlformat-list-start-value-func (x nitems) 
-  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems))
-
-(defclass xmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "" ; (std-xml-header)
-    :list-start-indent  t
-    :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
-    :list-start-value-func #'xmlformat-list-start-value-func
-    :list-end-indent  t
-    :list-end-fmtstr "</~a>~%"
-    :list-end-value-func #'xmlformat-list-end-value-func
-    :obj-start-fmtstr "<~a>"
-    :obj-start-value-func #'class-name-of
-    :obj-start-indent t
-    :obj-end-fmtstr "</~a>~%"
-    :obj-end-value-func #'class-name-of
-    :obj-end-indent nil
-    :obj-data-indent nil
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
-    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
-
-(defclass link-ref ()
-  ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
-   (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
-   (page-name :type string :initarg :page-name :accessor page-name)
-   (href-head :type string :initarg :href-head :accessor href-head)
-   (href-end :type string :initarg :href-end :accessor href-end)
-   (ampersand :type string :initarg :ampersand :accessor ampersand))
-  (:default-initargs :fmtstr nil 
-    :fmtstr-labels nil 
-    :page-name "disp-func1" 
-    :href-head nil :href-end nil :ampersand nil)
-  (:documentation "Formatting for a linked hyperlink"))
-
-(defclass html-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
-    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
-    :href-head "a href=" 
-    :href-end "a" 
-    :ampersand "&"))
-
-(defclass xhtml-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
-    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
-    :href-head "a href=" 
-    :href-end "a" 
-    :ampersand "&amp;"))
-
-(defclass xml-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref 
-                    :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
-                    :href-head "xmllink xlink:type=\"simple\" xlink:href=" 
-                    :href-end "xmllink" 
-                    :ampersand "&amp;")
-  (:documentation "Mozilla's and W3's idea of a link with XML"))
-
-(defclass ie-xml-link-ref (xml-link-ref)
-  ()
-  (:default-initargs :href-head "html:a href=" 
-                    :href-end "html:a" )
-  (:documentation "Internet Explorer's idea of a link with XML"))
-
-
-(defclass htmlrefformat (htmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'html-link-ref)))
-
-(defclass xhtmlrefformat (xhtmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
-
-(defclass xmlrefformat (xmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'xml-link-ref)))
-
-(defclass ie-xmlrefformat (xmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
+(defvar +newline-string+ (format nil "~%"))
+
+(defun initialize-text-view (view)
+  (setf (list-start-str-or-func view)
+       (compile nil
+                #'(lambda (obj nitems strm)
+                    (format strm "~a~P:~%"
+                            (hyperobject-class-user-name obj) nitems))))
+  (setf (list-start-indent view) t)
+  (setf (obj-data-indent view) t)
+  (setf (obj-data-end-str view) +newline-string+))
+
+(defun html-list-start-func (obj nitems strm)
+  (format strm "<p><b>~a~p:</b></p><div class=\""
+         (hyperobject-class-user-name obj) nitems)
+  (write-string (class-name-of obj) strm)
+  (write-string "\"><ul>" strm)
+  (write-char #\newline strm))
+
+(defun initialize-html-view (view)
+  (initialize-text-view view)
+  (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-str-or-func view) #'html-list-start-func)
+  (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
+  (setf (list-end-indent view) t)
+  (setf (obj-start-indent view) t)
+  (setf (obj-start-str-or-func view) "<li>")
+  (setf (obj-end-indent view)  t)
+  (setf (obj-end-str-or-func view)  (format nil "</li>~%"))
+  (setf (obj-data-indent view) t))
+
+(defun initialize-xhtml-view (view)
+  (initialize-text-view view)
+  (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-str-or-func view) #'html-list-start-func)
+  (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
+  (setf (list-end-indent view) t)
+  (setf (obj-start-indent view) t)
+  (setf (obj-start-str-or-func view) "<li>")
+  (setf (obj-end-indent view)  t)
+  (setf (obj-end-str-or-func view) (format nil "</li>~%"))
+  (setf (obj-data-indent view) t))
+
+(defun xmlformat-list-end-func (x strm)
+  (write-string "</" strm)
+  (write-string (class-name-of x) strm)
+  (write-string "list" strm)
+  (write-string ">" strm)
+  (write-char #\newline strm))
+
+(defun xmlformat-list-start-func (x nitems strm)
+  (write-char #\< strm)
+  (write-string (class-name-of x) strm)
+  (write-string "list><title>" strm)
+  (format strm "~A~P:</title> ~%"
+         (hyperobject-class-user-name x) nitems))
+
+(defun initialize-xml-view (view)
+  (initialize-text-view view)
+  (setf (file-start-str view) "") ; (std-xml-header)
+  (setf (list-start-indent view)  t)
+  (setf (list-start-str-or-func view) #'xmlformat-list-start-func)
+  (setf (list-end-indent view) t)
+  (setf (list-end-str-or-func view) #'xmlformat-list-end-func)
+  (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view)))
+  (setf (obj-start-indent view) t)
+  (setf (obj-end-str-or-func view) (format nil "</~(~a~)>~%" (object-class-name view)))
+  (setf (obj-end-indent view) nil)
+  (setf (obj-data-indent view) nil))
 
 
 ;;; File Start and Ends
 
-(defgeneric fmt-file-start (fmt s))
-(defmethod fmt-file-start ((fmt dataformat) (s stream)))
-
-(defmethod fmt-file-start ((fmt textformat) (s stream))
-  (aif (file-start-str fmt)
-      (format s it)))
+(defun fmt-file-start (view strm)
+  (awhen (file-start-str view)
+        (write-string it strm)))
 
-(defgeneric fmt-file-end (fmt s))
-(defmethod fmt-file-end ((fmt textformat) (s stream))
-  (aif (file-end-str fmt)
-         (format s it)))
+(defun fmt-file-end (view strm)
+  (awhen (file-end-str view)
+        (write-string it strm)))
 
 ;;; List Start and Ends
 
-(defgeneric fmt-list-start (obj fmt s &optional indent num-items))
-(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
-  (if (list-start-indent fmt)
-      (indent-spaces indent s))
-  (aif (list-start-fmtstr fmt)
-         (apply #'format s it
-                (multiple-value-list
-                 (funcall (list-start-value-func fmt) x num-items)))))
-
-(defgeneric fmt-list-end (obj fmt s &optional indent num-items))
-(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
+(defun fmt-list-start (obj view strm indent num-items)
+  (when (list-start-indent view)
+    (indent-spaces indent strm))
+  (awhen (list-start-str-or-func view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj num-items strm))))
+
+(defun fmt-list-end (obj view strm indent num-items)
   (declare (ignore num-items))
-  (if (list-end-indent fmt)
-      (indent-spaces indent s))
-  (aif (list-end-fmtstr fmt)
-         (apply #'format s it
-                (multiple-value-list
-                 (funcall (list-end-value-func fmt) x)))))
+  (when (list-end-indent view)
+      (indent-spaces indent strm))
+  (awhen (list-end-str-or-func view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm))))
 
 ;;; Object Start and Ends
 
-(defgeneric fmt-obj-start (obj fmt s &optional indent))
-(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
-  (if (obj-start-indent fmt)
-      (indent-spaces indent s))
-  (aif (obj-start-fmtstr fmt)
-         (apply #'format s it
-                (multiple-value-list
-                 (funcall (obj-start-value-func fmt) x)))))
-
-(defgeneric fmt-obj-end (obj fmt s &optional indent))
-(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
-  (if (obj-end-indent fmt)
-      (indent-spaces indent s))
-  (aif (obj-end-fmtstr fmt)
-         (apply #'format s it
-                (multiple-value-list
-                 (funcall (obj-end-value-func fmt) x)))))
+(defun fmt-obj-start (obj view strm indent)
+  (when (obj-start-indent view)
+    (indent-spaces indent strm))
+  (awhen (obj-start-str-or-func view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm))))
+
+(defun fmt-obj-end (obj view strm indent)
+  (when (obj-end-indent view)
+    (indent-spaces indent strm))
+  (awhen (obj-end-str-or-func view)
+        (if (stringp it)
+            (write-string it strm)
+            (funcall it obj strm))))
   
 ;;; Object Data 
 
-(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
-(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
-  (declare (ignore obj fieldname))
+(defun make-link-start (view fieldfunc fieldvalue refvars)
   (format nil "~a\"~a?func=~a~akey=~a~a\"" 
-         (href-head ref) (make-url (page-name ref)) fieldfunc 
-         (ampersand ref) fieldvalue
+         (link-href-start view)
+         (make-url (link-page-name view))
+         fieldfunc 
+         (link-ampersand view) fieldvalue
          (if refvars
              (let ((varstr ""))
                (dolist (var refvars)
-                 (string-append varstr (format nil "~a~a=~a" 
-                                               (ampersand ref) (car var) (cadr var))))
+                 (string-append
+                  varstr (link-ampersand view)
+                  (format nil "~a=~a" (car var) (cadr var))))
                varstr)
-           "")))
+             "")))
 
-(defgeneric make-link-end (obj ref fieldname)) 
-(defmethod make-link-end (obj (ref link-ref) fieldname)
+(defun make-link-end (obj view fieldname)
   (declare (ignore obj fieldname))
-  (format nil "~a" (href-end ref))
-  )
-
-(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
-(defmethod fmt-obj-data (x (fmt textformat) s
-                        &optional (indent 0) (label nil) (refvars nil))
-  (if (obj-data-indent fmt)
-      (indent-spaces indent s))
-  (if (link-ref fmt)
-      (fmt-obj-data-with-ref x fmt s label refvars)
-    (fmt-obj-data-plain x fmt s label))
-  (aif (obj-data-end-fmtstr fmt)
-       (format s it)))
-
-(defgeneric fmt-obj-data-plain (obj fmt s label))
-(defmethod fmt-obj-data-plain (x (fmt textformat) s label)
-  (if label
-      (apply #'format s
-            (funcall (obj-data-fmtstr-labels fmt) x)
-            (multiple-value-list 
-             (funcall (funcall (obj-data-value-func fmt) x) x)))
-    (apply #'format s (funcall (obj-data-fmtstr fmt) x)
-          (multiple-value-list
-           (funcall (funcall (obj-data-value-func fmt) x) x)))))
-
-(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
-(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
+  (link-href-end view))
+
+(defun fmt-obj-data (obj view strm indent refvars)
+  (when (obj-data-indent view)
+    (indent-spaces indent strm))
+  (if (link-slots view)
+      (fmt-obj-data-with-link obj view strm refvars)
+      (fmt-obj-data-plain obj view strm))
+  (awhen (obj-data-end-str view)
+        (write-string it strm)))
+
+(defun fmt-obj-data-plain (obj view strm)
+  (awhen (obj-data-func view)
+        (funcall it obj strm nil)))
+
+(defun fmt-obj-data-with-link (obj view strm refvars)
   (let ((refvalues '()))
     ;; make list of hyperlink link fields for printing to refstr template
-    (dolist (name (hyperobject-class-print-slots x))
-      (let-when (hyperlink (find name (hyperobject-class-hyperlinks x) :key #'name))
-       (push  (make-link-start x (link-ref fmt) name (lookup hyperlink)
-                               (slot-value x name)
-                               (append (link-parameters hyperlink) refvars))
-              refvalues)
-       (push (make-link-end x (link-ref fmt) name) refvalues)))
-    (setq refvalues (nreverse refvalues))
-    (apply #'format s (make-ref-data-str x fmt label) refvalues)))
-
-(defgeneric obj-data (obj))
-(defmethod obj-data (x)
+    (dolist (name (link-slots view))
+      (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
+            (push (make-link-start view (lookup it) (slot-value obj name)
+                                   (append (link-parameters it) refvars))
+                  refvalues)
+            (push (make-link-end obj view name) refvalues)))
+    (funcall (obj-data-func view) obj strm (nreverse refvalues))))
+
+(defun obj-data (obj view)
   "Returns the objects data as a string. Used by common-graphics outline function"
-  (let ((fmt (make-format-instance :text)))
-    (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
-          (multiple-value-list 
-           (funcall (funcall (obj-data-value-func fmt) x) x)))))
-
-(defgeneric make-ref-data-str (obj fmt &optional label))
-(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
-  "Return fmt string for that contains ~a slots for hyperlink link start and end"
-  (unless (link-ref fmt)
-    (error "fmt does not contain a link-ref"))
-  (let ((refstr 
-        (if label
-            (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
-                   (multiple-value-list
-                     (funcall (funcall (obj-data-value-func fmt) x) x)))
-          (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
-                 (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
-    refstr))
-  
+  (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
+
 ;;; Display method for objects
 
 
-(defgeneric load-all-subobjects (objs))
-(defmethod load-all-subobjects (objs)
+(defun load-all-subobjects (objs)
   "Load all subobjects if they have not already been loaded."
-  (when objs
-    (let ((objlist (mklist objs)))
+  (dolist (obj (mklist objs))
+    (dolist (subobj (hyperobject-class-subobjects obj))
+      (awhen (slot-value obj (name-slot subobj))
+            (load-all-subobjects it))))
+  objs)
+
+(defun view-hyperobject (objs view category strm &optional (indent 0) filter
+                        subobjects refvars)
+  "Display a single or list of hyperobject-class instances and their subobjects"
+  (let-when (objlist (mklist objs))
+    (let ((nobjs (length objlist))
+         (*print-pretty* nil)
+         (*print-circle* nil)
+         (*print-escape* nil)
+         (*print-readably* nil)
+         (*print-length* nil)
+         (*print-level* nil))
+      (fmt-list-start (car objlist) view strm indent nobjs)
       (dolist (obj objlist)
-        (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
-          (dolist (child-obj it)   ;; for each child function
-            (awhen (slot-value obj (name-slot child-obj))
-              (load-all-subobjects it))))))
-    objs))
-
-(defgeneric view-hyperobject (objs fmt strm
-                                 &optional label english-only-function
-                                 indent subobjects refvars))
-
-(defmethod view-hyperobject (objs (fmt dataformat) (strm stream) 
-                                &optional (label nil) (indent 0)
-                                (english-only-function nil)
-                                (subobjects nil) (refvars nil))
-"Display a single or list of hyperobject-class instances and their subobjects"
-  (when objs
-    (setq objs (mklist objs))
-    (let ((nobjs (length objs)))
-      (fmt-list-start (car objs) fmt strm indent nobjs)
-      (dolist (obj objs)
-        (unless (and english-only-function
-                 (multiple-value-bind (eng term) (funcall english-only-function obj)
-                   (and term (not eng))))
-          (fmt-obj-start obj fmt strm indent)
-          (fmt-obj-data obj fmt strm (1+ indent) label refvars)
-          (if subobjects
-              (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
-                        (dolist (child-obj it)   ;; for each child function
-                          (awhen (slot-value obj (name-slot child-obj)) ;; access set of child objects
-                                (view-hyperobject it fmt strm label 
-                                                  (1+ indent) english-only-function
-                                                  subobjects refvars)))))
-          (fmt-obj-end obj fmt strm indent)))
-      (fmt-list-end (car objs) fmt strm indent nobjs))
-    t))
-
-
-(defun view (objs &key (os *standard-output*) (format :text)
-                     (label nil) (english-only-function nil)
-                     (subobjects nil) (file-wrapper t) (refvars nil))
+        (unless (and filter (not (funcall filter obj)))
+          (fmt-obj-start obj view strm indent)
+          (fmt-obj-data obj view strm (1+ indent) refvars)
+          (when (and subobjects (hyperobject-class-subobjects obj))
+           (dolist (subobj (hyperobject-class-subobjects obj))
+             (aif (slot-value obj (name-slot subobj))
+                  (view-hyperobject it (get-category-view (car (mklist it)) category)
+                                    category strm (1+ indent) filter
+                                    subobjects refvars))))
+         (fmt-obj-end obj view strm indent)))
+      (fmt-list-end (car objlist) view strm indent nobjs)))
+  objs)
+
+
+(defun view (objs &key (stream *standard-output*) category view
+            filter subobjects refvars file-wrapper)
   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
-  (let ((fmt (make-format-instance format)))
-    (if file-wrapper
-       (fmt-file-start fmt os))
-    (when objs
-      (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
-    (if file-wrapper
-       (fmt-file-end fmt os)))
+  (let-when (objlist (mklist objs))
+    (when category
+      (setq view (get-category-view (car objlist) category)))
+    (unless view
+      (setq view (default-view (class-of (car objlist)))))
+    (when file-wrapper
+      (fmt-file-start view stream))
+    (view-hyperobject objlist view category stream 0 filter subobjects refvars)
+    (when file-wrapper
+      (fmt-file-end view stream)))
   objs)
 
 
 
 (defun fmt-comma-integer (i)
   (format nil "~:d" i))
-