From 7e2d980b24a9fb31501fe3911582a6d85c374494 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 14 Jul 2003 04:10:02 +0000
Subject: [PATCH] r5304: *** empty log message ***

---
 base-class.lisp |   4 +-
 mop.lisp        | 153 ++++++++++++-------------------------
 package.lisp    |   3 +-
 rules.lisp      |  29 ++++---
 views.lisp      | 196 +++++++++++++++++++++++++++---------------------
 5 files changed, 174 insertions(+), 211 deletions(-)

diff --git a/base-class.lisp b/base-class.lisp
index 9682f3d..ad7920f 100644
--- a/base-class.lisp
+++ b/base-class.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: base-class.lisp,v 1.10 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id: base-class.lisp,v 1.11 2003/07/14 04:10:02 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -22,6 +22,6 @@
 
 (defmethod print-object ((obj hyperobject) (s stream))
   (print-unreadable-object (obj s :type t :identity nil)
-    (funcall (obj-data-printer (get-category-view obj :compact-text))
+    (funcall (obj-data-printer (get-view-id obj :compact-text))
 	     obj s nil)))
 
diff --git a/mop.lisp b/mop.lisp
index 4ea6068..e42ee8b 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.83 2003/07/11 18:02:41 kevin Exp $
+;;;; $Id: mop.lisp,v 1.84 2003/07/14 04:10:02 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -78,12 +78,14 @@
   (:documentation "Metaclass for Markup Language classes."))
 
 (defclass subobject ()
-  ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)
-   (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
-   (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup)
-   (lookup-keys :type list :initform nil :initarg :lookup-keys
-		:reader lookup-keys))
-  (:documentation "Contains subobject information"))
+  ((name-class :type symbol :initarg :name-class :reader name-class)
+   (name-slot :type symbol :initarg :name-slot :reader name-slot)
+   (subobj-class :type symbol :initarg :subobj-class :reader subobj-class)
+   (lookup :type (or function symbol) :initarg :lookup :reader lookup)
+   (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
+  (:documentation "subobject information")
+  (:default-initargs :name-class nil :name-slot nil :subobj-class nil
+		     :lookup nil :lookup-keys nil))
 
 
 (defmethod print-object ((obj subobject) (s stream))
@@ -344,89 +346,37 @@ SQL name"
 
 ;;;; Class initialization function
 
-;; defines a slot-unbound method for class and slot-name, fills
-;; the slot by calling reader function with the slot values of
-;; the instance's reader-keys
-(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
-  (let* ((the-slot-name (gensym))
-	 (the-class (gensym))
-	 (the-instance (gensym))
-	 (keys '()))
-    (dolist (key reader-keys)
-      (push (list 'slot-value the-instance (list 'quote key)) keys))
-    (setq keys (nreverse keys))
-    `(defmethod slot-unbound (,the-class (,the-instance ,class)
-			      (,the-slot-name (eql ',slot-name)))
-      (declare (ignore ,the-class))
-      (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))
-
-
-#+lispworks
-(defun intern-eql-specializer (slot)
-  `(eql ,slot))
-
-#+(or sbcl cmu lispworks)
-(defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)
-  (let ((keys nil)
-	(gf (ensure-generic-function 'slot-unbound)))
-    (dolist (key reader-keys)
-      (push (list 'slot-value 'the-instance (list 'quote key)) keys))
-    (setq keys (nreverse keys))
-    (multiple-value-bind (method-lambda init-args-values)
-	(make-method-lambda
-	 gf
-	 (class-prototype (generic-function-method-class gf))
-	 #-lispworks
-	 `(lambda (the-class the-instance the-slot-name)
-	   (declare (ignore the-class))
-	   (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))
-	 #+lispworks
-	 '(the-class the-instance the-slot-name)
-	 #+lispworks
-	 nil
-	 #+lispworks
-	 `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))
-	 nil)
-      (add-method gf
-		  (apply
-		   #'make-instance (generic-function-method-class gf)
-		   ':specializers (list (class-of (find-class class-name))
-					(find-class class-name)
-					(intern-eql-specializer slot-name))
-		   ':lambda-list '(the-class the-instance the-slot-name)
-		   ':function (compile nil method-lambda)
-		   init-args-values)))))
-
-#+(or allegro scl openmcl)
-(progn
-  ;; One entry for each class with lazy readers defined.  The value is a plist mapping
-  ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.
-  (defvar *lazy-readers* (make-hash-table))
+;; One entry for each class with lazy readers defined.  The value is a plist mapping
+;; slot-name to a lazy reader, each of which is a list of a function and slot-names.
+(defvar *lazy-readers* (make-hash-table))
 
 (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)
   (let ((lazy-reader (loop for super in (class-precedence-list class)
-			   as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)
-			   when lazy-reader return it)))
+			 as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)
+			 when lazy-reader return it)))
     (if lazy-reader
 	(setf (slot-value instance slot-name)
-	      (apply (car lazy-reader)
-		     (loop for arg-slot-name in (cdr lazy-reader)
-			   collect (slot-value instance arg-slot-name))))
-	;; No lazy reader -- defer to regular slot-unbound handling.
-	(call-next-method))))
-
-  ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
-  ;; the result of applying the function to the slot-values of those slots, and that value
-  ;; is also returned.
-  (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)
-    (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
-	  (list* reader (copy-list reader-keys))))
-
-  (defun remove-lazy-reader (class-name slot-name)
-    (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
-	  nil))
-  
-  ) ;; #+(or allegro sc openmcll)
+	  (if (atom lazy-reader)
+	      (make-instance lazy-reader)
+	    (apply (car lazy-reader)
+		   (loop for arg-slot-name in (cdr lazy-reader)
+		       collect (slot-value instance arg-slot-name)))))
+      ;; No lazy reader -- defer to regular slot-unbound handling.
+      (call-next-method))))
+
+;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
+;; the result of applying the function to the slot-values of those slots, and that value
+;; is also returned.
+(defun ensure-lazy-reader (class-name slot-name subobj-class reader 
+			   &rest reader-keys)
+  (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
+    (aif subobj-class
+	 it
+	 (list* reader (copy-list reader-keys)))))
+
+(defun remove-lazy-reader (class-name slot-name)
+  (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
+    nil))
 
 
 (defun finalize-subobjects (cl)
@@ -440,30 +390,24 @@ SQL name"
 		    (make-instance 'subobject
 				   :name-class (class-name cl)
 				   :name-slot (slot-definition-name slot)
-				   :lookup (if (atom subobj-def)
-					       subobj-def
-					       (car subobj-def))
-				   :lookup-keys (if (atom subobj-def)
-						    nil
-						    (cdr subobj-def)))))
+				   :subobj-class (when (atom subobj-def)
+						   subobj-def)
+				   :lookup (when (listp subobj-def)
+					     (car subobj-def))
+				   :lookup-keys (when (listp subobj-def)
+						  (cdr subobj-def)))))
 	       (unless (eq (lookup subobject) t)
-		 #+ignore ;; #-(or sbcl cmu lispworks)
-		 (eval
-		  `(hyperobject::def-lazy-reader ,(name-class subobject)
-		    ,(name-slot subobject) ,(lookup subobject)
-		    ,@(lookup-keys subobject)))
-		 #+(or sbcl cmu lispworks allegro scl openmcl)
 		 (apply #'ensure-lazy-reader 
 			(name-class subobject) (name-slot subobject)
-			(lookup subobject) (lookup-keys subobject)))
-	       (push subobject subobjects))))
+			(subobj-class subobject)
+			(lookup subobject) (lookup-keys subobject))
+		 (push subobject subobjects)))))
 	  ;; sbcl/cmu reverse class-slots compared to the defclass form
 	  ;; so re-reverse on cmu/sbcl
 	  #+(or cmu sbcl) subobjects
 	  #-(or cmu sbcl) (nreverse subobjects)
 	  )))
 
-
 (defun finalize-class-slots (cl)
   "Make sure all class slots have an expected value"
   (unless (user-name cl)
@@ -477,13 +421,12 @@ SQL name"
 				   (user-name cl))
 		    2)))
 
-  (dolist (name '(user-name description version guid sql-name
-		  direct-views direct-rules))
+  (dolist (name '(user-name description version guid sql-name))
     (awhen (slot-value cl name)
 	   (setf (slot-value cl name)
-		 (etypecase (slot-value cl name)
-		   (cons (car it))
-		   ((or string symbol) it)))))
+	     (if (listp it)
+		 (car it)
+	       it))))
   
   (unless (sql-name cl)
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))
diff --git a/package.lisp b/package.lisp
index 1f00144..a52e65e 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.50 2003/06/24 08:32:32 kevin Exp $
+;;;; $Id: package.lisp,v 1.51 2003/07/14 04:10:02 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -44,6 +44,7 @@
    #:hyperobject-class-user-name
    #:load-all-subobjects
    #:view
+   #:view-subobjects
    #:fmt-comma-integer
    #:processed-queued-definitions
    #:all-subobjects
diff --git a/rules.lisp b/rules.lisp
index 336c86f..3807676 100644
--- a/rules.lisp
+++ b/rules.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: rules.lisp,v 1.47 2003/06/20 08:35:21 kevin Exp $
+;;;; $Id: rules.lisp,v 1.48 2003/07/14 04:10:02 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -36,21 +36,18 @@
 		     ,@source-code)))))))
   
 (defun finalize-rules (cl)
-  (let* ((direct-rules (direct-rules cl))
-	 (rules '()))
-    (dolist (rule direct-rules)
-      (destructuring-bind (name (&key dependants volatile) &rest source-code)
-	  rule
-	(setf dependants (mklist dependants)
-	      volatile (mklist volatile))
-	(push
-	 (make-instance 'rule :name name :dependants dependants
-			:volatile volatile :source-code source-code
-			:access-slots (appendnew dependants volatile)
-			:func (compile-rule
-			       source-code dependants volatile cl))
-	 rules)))
-    (setf (rules cl) (nreverse rules))))
+  (setf (rules cl)
+    (loop for rule in (direct-rules cl)
+	collect 
+	  (destructuring-bind (name (&key dependants volatile) &rest source-code)
+	      rule
+	    (setf dependants (mklist dependants)
+		  volatile (mklist volatile))
+	    (make-instance 'rule :name name :dependants dependants
+			   :volatile volatile :source-code source-code
+			   :access-slots (appendnew dependants volatile)
+			   :func (compile-rule
+				  source-code dependants volatile cl))))))
 
 
 (defun fire-class-rules (cl obj slot)
diff --git a/views.lisp b/views.lisp
index 6c10296..cd4f69b 100644
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $
+;;;; $Id: views.lisp,v 1.61 2003/07/14 04:10:02 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -21,10 +21,8 @@
 		 :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.")
+   (id :initform nil :initarg :id :accessor id
+       :documentation "id for this view.")
    (source-code :initform nil :initarg :source-code :accessor source-code 
 		:documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language
@@ -95,21 +93,42 @@
   (:documentation "View class for a hyperobject"))
 
 
-(defun get-category-view (obj category &optional slots)
+(defun get-default-view-id (obj-cl)
+  (aif (views obj-cl)
+      (id (car it))
+      :compact-text))
+
+(defun find-view-id-in-class-precedence (obj-cl vid)
+  "Looks for a view in class and parent classes"
+  (when (typep obj-cl 'hyperobject-class)
+    (aif (find vid (views obj-cl) :key #'id :test #'eq)
+	 it
+	 (let (cpl)
+	   (handler-case
+	       (setq cpl (class-precedence-list obj-cl))
+	     (error (e)
+	       (declare (ignore e))
+	       ;; can't get cpl unless class finalized
+	       (make-instance (class-name obj-cl))
+	       (setq cpl (class-precedence-list obj-cl))))
+	   (find-view-id-in-class-precedence (second cpl) vid)))))
+					    
+  
+(defun get-view-id (obj vid &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 (find-class obj-class)
-		      :category category
-		      :slots slots)))
-	       (push view (views obj-class))
-	       view)))))
-			     
+  (let ((obj-cl (class-of obj)))
+    (unless vid
+      (setq vid (get-default-view-id obj-cl)))
+    (aif (find-view-id-in-class-precedence obj-cl vid)
+	 it
+	 (let ((view
+		(make-instance 'object-view
+		  :object-class (class-name obj-cl)
+		  :id vid
+		  :slots slots)))
+	   (push view (views obj-cl))
+	   view))))
+
 ;;;; *************************************************************************
 ;;;;  Metaclass Intialization
 ;;;; *************************************************************************
@@ -119,15 +138,9 @@
   (unless (default-print-slots cl)
     (setf (default-print-slots cl)
 	  (mapcar #'slot-definition-name (class-slots cl))))
-  (let ((views '()))
-    (dolist (view-def (direct-views cl))
-      (push (make-object-view cl view-def) views))
-    (setf (views cl) (nreverse views)))
-  (cond
-    ((views cl)
-     (setf (default-view cl) (car (views cl))))
-    (t
-     (setf (default-view cl) (make-object-view cl :default)))))
+  (setf (views cl)
+    (loop for view-def in (direct-views cl)
+	collect (make-object-view cl view-def))))
 
 (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"
@@ -135,22 +148,21 @@
     ((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 (class-name cl)
-				 :category :compact-text)))
-       view))
+     (make-instance 'object-view 
+       :object-class (class-name cl)
+       :id :compact-text))
     ((consp view-def)
      (make-instance 'object-view
 		    :object-class (class-name cl)
-		    :name (getf view-def :name)
+		    :id (getf view-def :id)
+		    :slots (getf view-def :slots)
 		    :source-code (getf view-def :source-code)))
     (t
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
 (defmethod initialize-instance :after ((self object-view)
 				       &rest initargs 
-				       &key 
+				       &key
 				       &allow-other-keys)
   (initialize-view self))
   
@@ -158,21 +170,33 @@
   "Calculate all view slots for a hyperobject class"
   (let ((obj-cl (find-class (object-class view))))
     (cond
-     ((category view)
-      (initialize-view-by-category obj-cl view))
      ((source-code view)
       (initialize-view-by-source-code view))
+     ((id view)
+      (initialize-view-by-id obj-cl view))
      (t
-      (setf (category view) :compact-text)
-      (initialize-view-by-category obj-cl view)))))
+      (setf (id view) :compact-text)
+      (initialize-view-by-id obj-cl view)))))
+
+
 
 (defun initialize-view-by-source-code (view)
   "Initialize a view based upon a source code"
   (let* ((source-code (source-code view))
-	 (*package* (symbol-package (object-class view)))
-	 (printer `(lambda (x s)
-		     (declare (ignorable x s))
-		     ,@source-code)))
+	 (printer `(lambda
+		       (,(intern (symbol-name '#:self) 
+				 (symbol-package (object-class view)))
+			,(intern (symbol-name '#:s) 
+				 (symbol-package (object-class view))))
+		     (declare (ignorable 
+			       ,(intern (symbol-name '#:self) 
+					(symbol-package (object-class view)))
+			       ,(intern (symbol-name '#:s) 
+					(symbol-package (object-class view)))))
+		     (with-slots ,(slots view) 
+			 ,(intern (symbol-name '#:self) 
+				  (symbol-package (object-class view)))
+		       ,@source-code))))
     (setf (printer view) 
       (compile nil (eval printer)))))
 
@@ -247,7 +271,7 @@
   (vector-push-extend '(write-string "</span> " s) print-func)
   (ppfc-html-link name type formatter cdata nlink print-func))
 
-(defun push-print-fun-code (category slot nlink print-func)
+(defun push-print-fun-code (vid slot nlink print-func)
   (let* ((formatter (esd-print-formatter slot))
 	 (name (slot-definition-name slot))
 	 (user-name (esd-user-name slot))
@@ -255,7 +279,7 @@
 	 (xml-tag (escape-xml-string user-name))
 	 (type (slot-value slot 'type))
 	 (cdata (not (null
-		      (and (in category :xml :xhtml :xml-link :xhtml-link
+		      (and (in vid :xml :xhtml :xml-link :xhtml-link
 			       :xml-labels :ie-xml-labels
 			       :xhtml-link-labels :xml-link-labels :ie-xml-link
 			       :ie-xml-link-labels)
@@ -263,7 +287,7 @@
 			       (lisp-type-is-a-string type))))))
 	 (hyperlink (esd-hyperlink slot)))
     
-    (case category
+    (case vid
       (:compact-text
        (vector-push-extend
 	`(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
@@ -310,20 +334,25 @@
 
 
 (defun view-has-links-p (view)
-  (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
+  (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
       :html-link-labels :xhtml-link-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
-	      :xhtml-link :html-link
-	      :xml :xml-labels :xml-link :ie-xml-link
-	      :xml-link-labels :ie-xml-link-labels
-	      :display-table :edit-table)
-    (error "Unknown view category ~A" (category view)))
+(defun creatable-view-id-p (obj-cl vid)
+  "Returns T if a view id can be created for this class"
+  (declare (ignore obj-cl))
+  (in vid :compact-text :compact-text-labels
+      :html :html-labels :html-link-labels
+      :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
+      :display-table :edit-table))
+
+(defun initialize-view-by-id (obj-cl view)
+  "Initialize a view based upon a preset vid"
+  (unless (creatable-view-id-p obj-cl (id view))
+    (error "Unable to automatically create view id ~A" (id view)))
   
   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 
@@ -338,7 +367,7 @@
       (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)
+      (push-print-fun-code (id view) slot (length links) print-func)
       (when (> (length slots) 1)
 	(vector-push-extend '(write-char #\space s) print-func))
 
@@ -354,11 +383,11 @@
     
     (setf (link-slots view) (nreverse links)))
 
-  (finalize-view-by-category view)
+  (finalize-view-by-id view)
   view)
 
-(defun finalize-view-by-category (view)
-  (case (category view)
+(defun finalize-view-by-id (view)
+  (case (id view)
     ((or :compact-text :compact-text-labels)
      (initialize-text-view view))
     ((or :html :html-labels)
@@ -390,12 +419,6 @@
      (setf (link-ampersand view) "&amp;"))))
 
 
-(defun make-std-object-slots-view (class-name slots)
-  #'(lambda (obj strm)
-      )
-    
-  )
-
 ;;;; *************************************************************************
 ;;;;  View Data Format Section
 ;;;; *************************************************************************
@@ -497,16 +520,17 @@
   (write-char #\newline strm))
 
 (defun initialize-xml-view (view)
-  (setf (file-start-str view) "") ; (std-xml-header)
-  (setf (list-start-indent view)  t)
-  (setf (list-start-printer view) #'xmlformat-list-start-func)
-  (setf (list-end-indent view) t)
-  (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 (subobj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
-  (setf (subobj-end-indent view) nil)
-  (setf (obj-data-indent view) nil))
+  (let ((name (string-downcase (symbol-name (object-class view)))))
+    (setf (file-start-str view) "")	; (std-xml-header)
+    (setf (list-start-indent view)  t)
+    (setf (list-start-printer view) #'xmlformat-list-start-func)
+    (setf (list-end-indent view) t)
+    (setf (list-end-printer view) #'xmlformat-list-end-func)
+    (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
+    (setf (obj-start-indent view) t)
+    (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
+    (setf (subobj-end-indent view) nil)
+    (setf (obj-data-indent view) nil)))
 
 
 ;;; File Start and Ends
@@ -656,18 +680,18 @@
 	     (load-all-subobjects it))))
   objs)
 
-(defun view-subobjects (obj strm &optional category (indent 0) filter
+(defun view-subobjects (obj strm &optional vid (indent 0) filter
 			subobjects refvars link-printer)
   (when (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
+	    it (get-view-id (car (mklist it)) vid)
+	    vid strm (1+ indent) filter subobjects refvars
 	    link-printer)))))
 
 	  
-(defun view-hyperobject (objs view strm &optional category (indent 0) filter
+(defun view-hyperobject (objs view strm &optional vid (indent 0) filter
 			 subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"
   (let-when (objlist (mklist objs))
@@ -688,24 +712,22 @@
 	  (fmt-obj-end obj view strm indent)
 	  (when subobjects 
 	    (fmt-subobj-start obj view strm indent)
-	    (view-subobjects obj category strm indent filter subobjects
+	    (view-subobjects obj vid strm indent filter subobjects
 			     refvars link-printer)
 	    (fmt-subobj-end obj view strm indent))))
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)
 
 
-(defun view (objs &key (stream *standard-output*) category view
+(defun view (objs &key (stream *standard-output*) vid view
 	     filter subobjects refvars file-wrapper link-printer)
   "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
   (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)))))
+      (setq view (get-view-id (car objlist) vid)))
     (when file-wrapper
       (fmt-file-start view stream))
-    (view-hyperobject objlist view stream category 0 filter subobjects refvars
+    (view-hyperobject objlist view stream vid 0 filter subobjects refvars
 		      link-printer)
     (when file-wrapper
       (fmt-file-end view stream)))
-- 
2.34.1