views.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          views.lisp
   6 ;;;; Purpose:       View methods for Hyperobjects
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: views.lisp,v 1.17 2002/12/24 06:30:29 kevin Exp $
  11 ;;;;
  12 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; *************************************************************************
  15
  16 (in-package :hyperobject)
  17
  18 (eval-when (:compile-toplevel :execute)
  19   (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
  20
  21
  22 (defclass object-view ()
  23   ((object-class :initform nil :initarg :object-class :accessor object-class
  24                  :documentation "Name of class for object to be viewed.")
  25    (slots :initform nil :initarg :slots :accessor slots
  26           :documentation "List of effective slots for object to be viewed.")
  27    (name :initform nil :initarg :name :accessor name
  28          :documentation "Name for this view.")
  29    (category :initform nil :initarg :category :accessor category
  30              :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
  31    (source-code :initform nil :initarg :source-code :accessor source-code
  32                 :documentation "Source code for generating view.")
  33    (country-language :initform :en :initarg :country-language
  34                      :documentation "Country's Language for this view.")
  35    ;;
  36    (file-start-str :type string :initform nil :initarg :file-start-str
  37                    :accessor file-start-str)
  38    (file-end-str :type string :initform nil :initarg :file-end-str
  39                  :accessor file-end-str)
  40    (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr
  41                       :accessor list-start-fmtstr)
  42    (list-start-value-func :type function :initform nil
  43                           :initarg :list-start-value-func
  44                           :accessor list-start-value-func)
  45    (list-start-indent :initform nil :initarg :list-start-indent
  46                       :accessor list-start-indent)
  47    (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr
  48                     :accessor list-end-fmtstr)
  49    (list-end-value-func :type function :initform nil
  50                         :initarg :list-end-value-func
  51                         :accessor list-end-value-func)
  52    (list-end-indent :initform nil :initarg :list-end-indent
  53                     :accessor list-end-indent)
  54    (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr
  55                      :accessor obj-start-fmtstr)
  56    (obj-start-value-func :initform nil :initarg :obj-start-value-func
  57                          :accessor obj-start-value-func)
  58    (obj-start-indent :initform nil :initarg :obj-start-indent
  59                      :accessor obj-start-indent)
  60    (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr
  61                    :accessor obj-end-fmtstr)
  62    (obj-end-value-func :type function :initform nil
  63                        :initarg :obj-end-value-func
  64                        :accessor obj-end-value-func)
  65    (obj-end-indent :initform nil :initarg :obj-end-indent
  66                    :accessor obj-end-indent)
  67    (obj-data-indent :initform nil :initarg :obj-data-indent
  68                     :accessor obj-data-indent)
  69    (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr
  70                     :accessor obj-data-fmtstr)
  71    (obj-data-end-fmtstr :type string :initform nil
  72                         :initarg :obj-data-end-fmtstr
  73                         :accessor obj-data-end-fmtstr)
  74    (obj-data-value-func :type function :initform nil
  75                         :initarg :obj-data-value-func
  76                         :accessor obj-data-value-func)
  77    (link-slots :type list :initform nil
  78                :documentation "List of slot names that have hyperlinks"
  79                :accessor link-slots)
  80    (link-page-name :type string :initform nil :initarg :link-page-name
  81                    :accessor link-page-name)
  82    (link-href-start :type string :initform nil :initarg :link-href-start
  83                     :accessor link-href-start)
  84    (link-href-end :type string :initform nil :initarg :link-href-end
  85                   :accessor link-href-end)
  86    (link-ampersand :type string :initform nil :initarg :link-ampersand
  87                    :accessor link-ampersand))
  88   (:default-initargs :link-page-name "disp-func1")
  89   (:documentation "View class for a hyperobject"))
  90
  91
  92 (defun get-category-view (obj category &optional slots)
  93   "Find or make a category view for an object"
  94   (let ((obj-class (class-of obj)))
  95     (if (null category)
  96         (default-view obj-class)
  97         (aif (find category (views obj-class) :key #'category)
  98              it
  99              (let ((view
 100                     (make-instance 'object-view :object-class (class-name obj-class)
 101                                    :category category
 102                                    :slots slots)))
 103                (push view (views obj-class))
 104                view)))))
 105
 106 ;;;; *************************************************************************
 107 ;;;;  Metaclass Intialization
 108 ;;;; *************************************************************************
 109
 110 (defun finalize-views (cl)
 111   "Finalize all views that are given on a objects initialization"
 112   (unless (default-print-slots cl)
 113     (setf (default-print-slots cl)
 114           (mapcar #'slot-definition-name (class-slots cl))))
 115   (let ((views '()))
 116     (dolist (view-def (views cl))
 117       (push (make-object-view cl view-def) views))
 118     (setf (views cl) (nreverse views)))
 119   (cond
 120     ((default-view cl)
 121      (setf (default-view cl) (make-object-view cl (default-view cl))))
 122     ((car (views cl))
 123      (setf (default-view cl) (make-object-view cl (car (views cl)))))
 124     (t
 125      (setf (default-view cl) (make-object-view cl :default)))))
 126
 127 (defun make-object-view (cl view-def)
 128   "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
 129   (cond
 130     ((typep view-def 'object-view)
 131      view-def)
 132     ((eq view-def :default)
 133      (let* ((name (class-name cl))
 134             (view (make-instance 'object-view :name "automatic"
 135                                  :object-class name
 136                                  :category :compact-text)))
 137        view))
 138     ((consp view-def)
 139      (eval `(make-instance ,view-def)))
 140     (t
 141      (error "Invalid parameter to make-object-view: ~S" view-def))))
 142
 143 (defmethod initialize-instance :after ((view object-view)
 144                                        &rest initargs &key &allow-other-keys)
 145   (initialize-view (find-class (object-class view)) view))
 146
 147 (defun initialize-view (obj-cl view)
 148   "Calculate all view slots for a hyperobject class"
 149   (cond
 150     ((category view)
 151      (initialize-view-by-category obj-cl view))
 152     ((source-code view)
 153      (initialize-view-by-source-code obj-cl view))
 154     (t
 155      (setf (category view) :compact-text)
 156      (initialize-view-by-category obj-cl view))))
 157
 158 (defun initialize-view-by-source-code (obj-cl view)
 159   "Initialize a view based upon a source code"
 160   (let ((source-code (source-code view)))
 161     (error "not implemented")
 162     )
 163   )
 164
 165
 166 (defun initialize-view-by-category (obj-cl view)
 167   "Initialize a view based upon a preset category"
 168   (let ((fmtstr nil)
 169         (first-field t)
 170         (value-func '())
 171         (links '())
 172         (category (category view)))
 173
 174     (unless (in category :compact-text :compact-text-labels
 175                 :html :html-labels :html-link-labels
 176                 :xhtml :xhtml-labels :xhtml-link-labels
 177                 :xml :xml-labels :xml-link :ie-xml-link
 178                 :xml-link-labels :ie-xml-link-labels)
 179       (error "Unknown view category ~A" category))
 180
 181     (unless (slots view)
 182       (setf (slots view) (default-print-slots obj-cl)))
 183     (dolist (slot-name (slots view))
 184       (let ((slot (find-slot-by-name obj-cl slot-name)))
 185         (unless slot
 186           (error "Slot ~A is not found in class ~S" slot-name obj-cl))
 187         (let ((name (slot-definition-name slot))
 188               (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
 189               (type (slot-value slot 'type))
 190               (print-formatter (esd-print-formatter slot)))
 191
 192           (cond
 193             (first-field
 194              (setq fmtstr "")
 195              (setq first-field nil))
 196             (t
 197              (string-append fmtstr " ")))
 198
 199           (let ((value-fmt
 200                  (case type
 201                    ((or :integer :fixnum)
 202                     "~d")
 203                    (:boolean
 204                     "~a")
 205                    (otherwise
 206                     "~a"))))
 207             (case category
 208               (:compact-text
 209                (string-append fmtstr value-fmt))
 210               (:compact-text-labels
 211                (string-append fmtstr namestr-lower " " value-fmt))
 212               ((or :html :xhtml)
 213                (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>")))
 214               (:xml
 215                (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">")))
 216               (:html-labels
 217                (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
 218               (:xhtml-labels
 219                (string-append fmtstr (concatenate 'string "<span class=\"label\"><![CDATA[" namestr-lower "]]></span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
 220               (:xml-labels
 221                (string-append fmtstr (concatenate 'string "<label><[!CDATA[" namestr-lower "]]></label> <" namestr-lower ">" value-fmt "</" namestr-lower ">")))
 222               ((or :html-link :xhtml-link)
 223                (push name links)
 224                (if (esd-hyperlink slot)
 225                    (string-append fmtstr "<~~a>" value-fmt "</~~a>")
 226                    (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 227               ((or :xml-link :ie-xml-link)
 228                (push name links)
 229                (if (esd-hyperlink slot)
 230                    (string-append fmtstr "<~~a>" value-fmt "</~~a>")
 231                    (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))))
 232               (:html-link-labels
 233                (push name links)
 234                (if (esd-hyperlink slot)
 235                    (string-append fmtstr "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 236                    (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 237               (:xhtml-link-labels
 238                (push name links)
 239                (if (esd-hyperlink slot)
 240                    (string-append fmtstr "<span class=\"label\"><[!CDATA[" namestr-lower "]]></span> <~~a>" value-fmt "</~~a>")
 241                    (string-append fmtstr (concatenate 'string "<span class=\"label\"><![CDATA[" namestr-lower "]]></span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 242               ((or :xml-link-labels :ie-xml-link-labels)
 243                (push name links)
 244                (if (esd-hyperlink slot)
 245                    (string-append fmtstr "<label><[![CDATA[" namestr-lower "]]></label> <~~a>" value-fmt "</~~a>")
 246                    (string-append fmtstr (concatenate 'string "<label><![CDATA[" namestr-lower "]]></label> <" namestr-lower ">" value-fmt "</" namestr-lower ">")))))
 247             ) ;; let value-fmt
 248
 249           (let ((func (if print-formatter
 250                   `(,print-formatter (slot-value x (quote ,name)))
 251                   `(slot-value x (quote ,name)))))
 252             (when (and (in category :xml :xhtml :xml-link :xhtml-link
 253                            :xhtml-link-labels :xml-link-labels :ie-xml-link
 254                            :ie-xml-link-labels)
 255                        (or print-formatter
 256                            (string-equal (write-to-string type) "string")))
 257               (setq func `(kmrcl:xml-cdata ,func)))
 258             (push func value-func))
 259           )))
 260
 261     (when value-func
 262       (setq value-func
 263             (compile nil (eval `(lambda (x) (values ,@(nreverse value-func)))))))
 264
 265     (setf (obj-data-fmtstr view) fmtstr)
 266     (setf (obj-data-value-func view) value-func)
 267     (setf (link-slots view) (nreverse links))
 268
 269     (case category
 270       ((or :compact-text :compact-text-labels)
 271        (initialize-text-view view))
 272       ((or :html :xhtml :html-labels :xhtml-labels)
 273        (initialize-html-view view))
 274       ((or :xml :xml-labels)
 275        (initialize-xml-view view))
 276       ((or :html-link :html-link-labels)
 277        (initialize-html-view view)
 278        (setf (link-href-start view) "a href=")
 279        (setf (link-href-end view) "a")
 280        (setf (link-ampersand view) "&"))
 281       ((or :xhtml-link :xhtml-link-labels)
 282        (initialize-html-view view)
 283        (setf (link-href-start view) "a href=")
 284        (setf (link-href-end view) "a")
 285        (setf (link-ampersand view) "&amp;"))
 286       ((or :xml-link :xml-link-labels)
 287        (initialize-xml-view view)
 288        (setf (link-href-start view)
 289              "xmllink xlink:type=\"simple\" xlink:href=")
 290        (setf (link-href-end view) "xmllink")
 291        (setf (link-ampersand view) "&amp;"))
 292       ((or :ie-xml-link :ie-xml-link-labels)
 293        (initialize-xml-view view)
 294        (setf (link-href-start view) "html:a href=")
 295        (setf (link-href-end view) "html:a")
 296        (setf (link-ampersand view) "&amp;"))))
 297   view)
 298
 299
 300 ;;;; *************************************************************************
 301 ;;;;  View Data Format Section
 302 ;;;; *************************************************************************
 303
 304 (defun class-name-of (obj)
 305   (string-downcase (class-name (class-of obj))))
 306
 307 (defun text-list-start-value-func (obj nitems)
 308   (values (hyperobject-class-user-name obj) nitems))
 309
 310 (defun htmlformat-list-start-value-func (x nitems)
 311   (values (hyperobject-class-user-name x) nitems (class-name-of x)))
 312
 313 (defun initialize-text-view (view)
 314   (setf (list-start-fmtstr view) "~a~P:~%")
 315   (setf (list-start-value-func view) #'text-list-start-value-func)
 316   (setf (list-start-indent view) t)
 317   (setf (obj-data-indent view) t)
 318   (setf (obj-data-end-fmtstr view) (format nil "~%"))
 319   )
 320
 321 (defun initialize-html-view (view)
 322   (initialize-text-view view)
 323   (setf (file-start-str view) (format nil "<html><body>~%"))
 324   (setf (file-end-str view) (format nil "</body><html>~%"))
 325   (setf (list-start-indent view) t)
 326   (setf (list-start-fmtstr view)
 327         "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
 328   (setf (list-start-value-func view)
 329         #'htmlformat-list-start-value-func)
 330   (setf (list-end-fmtstr view) (format nil "</ul></div>~%"))
 331   (setf (list-end-indent view) t)
 332   (setf (list-end-value-func view) nil)
 333   (setf (obj-start-indent view) t)
 334   (setf (obj-start-fmtstr view) "<li>")
 335   (setf (obj-start-value-func view) nil)
 336   (setf (obj-end-indent view)  t)
 337   (setf (obj-end-fmtstr view)  (format nil "</li>~%"))
 338   (setf (obj-end-value-func view) nil)
 339   (setf (obj-data-indent view) t))
 340
 341 (defun initialize-xhtml-view (view)
 342   (initialize-text-view view)
 343   (setf (file-start-str view) (format nil "<html><body>~%"))
 344   (setf (file-end-str view) (format nil "</body><html>~%"))
 345   (setf (list-start-indent view) t)
 346   (setf (list-start-fmtstr view)
 347         "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
 348   (setf (list-start-value-func view)
 349                     #'htmlformat-list-start-value-func)
 350   (setf (list-end-fmtstr view) (format nil "</ul></div>~%"))
 351   (setf (list-end-indent view) t)
 352   (setf (list-end-value-func view) nil)
 353   (setf (obj-start-indent view) t)
 354   (setf (obj-start-fmtstr view) "<li>")
 355   (setf (obj-start-value-func view) nil)
 356   (setf (obj-end-indent view)  t)
 357   (setf (obj-end-fmtstr view) (format nil "</li>~%"))
 358   (setf (obj-end-value-func view) nil)
 359   (setf (obj-data-indent view) t))
 360
 361 (defun xmlformat-list-end-value-func (x)
 362   (format nil "~alist" (class-name-of x)))
 363
 364 (defun xmlformat-list-start-value-func (x nitems)
 365   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems))
 366
 367 (defun initialize-xml-view (view)
 368   (initialize-text-view view)
 369   (setf (file-start-str view) "") ; (std-xml-header)
 370   (setf (list-start-indent view)  t)
 371   (setf (list-start-fmtstr view) "<~a><title>~a~p:</title> ~%")
 372   (setf (list-start-value-func view)
 373         #'xmlformat-list-start-value-func)
 374   (setf (list-end-indent view) t)
 375   (setf (list-end-fmtstr view) "</~a>~%")
 376   (setf (list-end-value-func view) #'xmlformat-list-end-value-func)
 377   (setf (obj-start-fmtstr view) (format nil "<~(~a~)>" (object-class view)))
 378   (setf (obj-start-indent view) t)
 379   (setf (obj-end-fmtstr view) (format nil "</~(~a~)>~%" (object-class view)))
 380   (setf (obj-end-indent view) nil)
 381   (setf (obj-data-indent view) nil))
 382
 383
 384 ;;; File Start and Ends
 385
 386 (defun fmt-file-start (view strm)
 387   (awhen (file-start-str view)
 388          (write-string it strm)))
 389
 390 (defun fmt-file-end (view strm)
 391   (awhen (file-end-str view)
 392          (write-string it strm)))
 393
 394 ;;; List Start and Ends
 395
 396 (defun fmt-list-start (obj view strm indent num-items)
 397   (when (list-start-indent view)
 398     (indent-spaces indent strm))
 399   (let-when (fmtstr (list-start-fmtstr view))
 400             (let-if (value-func (list-start-value-func view))
 401                     (apply #'format strm fmtstr
 402                            (multiple-value-list (funcall value-func
 403                                                          obj num-items)))
 404                     (write-string fmtstr strm))))
 405
 406 (defun fmt-list-end (obj view strm indent num-items)
 407   (declare (ignore num-items))
 408   (when (list-end-indent view)
 409       (indent-spaces indent strm))
 410   (let-when (fmtstr (list-end-fmtstr view))
 411             (let-if (value-func (list-end-value-func view))
 412                     (apply #'format strm fmtstr (multiple-value-list
 413                                                  (funcall value-func obj)))
 414                     (write-string fmtstr strm))))
 415
 416 ;;; Object Start and Ends
 417
 418 (defun fmt-obj-start (obj view strm indent)
 419   (when (obj-start-indent view)
 420     (indent-spaces indent strm))
 421   (let-when (fmtstr (obj-start-fmtstr view))
 422             (let-if (value-func (obj-start-value-func view))
 423                     (apply #'format strm fmtstr (multiple-value-list
 424                                                  (funcall value-func obj)))
 425                     (write-string fmtstr strm))))
 426
 427 (defun fmt-obj-end (obj view strm indent)
 428   (when (obj-end-indent view)
 429     (indent-spaces indent strm))
 430   (let-when (fmtstr (obj-end-fmtstr view))
 431             (let-if (value-func (obj-end-value-func view))
 432                     (apply #'format strm fmtstr (multiple-value-list
 433                                                  (funcall value-func obj)))
 434                     (write-string fmtstr strm))))
 435
 436 ;;; Object Data
 437
 438 (defun make-link-start (view fieldfunc fieldvalue refvars)
 439   (format nil "~a\"~a?func=~a~akey=~a~a\""
 440           (link-href-start view)
 441           (make-url (link-page-name view))
 442           fieldfunc
 443           (link-ampersand view) fieldvalue
 444           (if refvars
 445               (let ((varstr ""))
 446                 (dolist (var refvars)
 447                   (string-append
 448                    varstr (link-ampersand view)
 449                    (format nil "~a=~a" (car var) (cadr var))))
 450                 varstr)
 451               "")))
 452
 453 (defun make-link-end (obj view fieldname)
 454   (declare (ignore obj fieldname))
 455   (link-href-end view))
 456
 457 (defun fmt-obj-data (obj view strm indent refvars)
 458   (when (obj-data-indent view)
 459     (indent-spaces indent strm))
 460   (if (link-slots view)
 461       (fmt-obj-data-with-link obj view strm refvars)
 462       (fmt-obj-data-plain obj view strm))
 463   (awhen (obj-data-end-fmtstr view)
 464          (write-string it strm)))
 465
 466 (defun fmt-obj-data-plain (obj view strm)
 467   (awhen (obj-data-value-func view)
 468          (apply #'format strm (obj-data-fmtstr view)
 469                 (multiple-value-list (funcall it obj)))))
 470
 471 (defun fmt-obj-data-with-link (obj view strm refvars)
 472   (let ((refvalues '()))
 473     ;; make list of hyperlink link fields for printing to refstr template
 474     (dolist (name (link-slots view))
 475       (let-when (hyperlink
 476                  (find name (hyperobject-class-hyperlinks obj) :key #'name))
 477                 (push  (make-link-start view (lookup hyperlink) (slot-value obj name)
 478                                         (append (link-parameters hyperlink) refvars))
 479                        refvalues)
 480                 (push (make-link-end obj view name) refvalues)))
 481     (setq refvalues (nreverse refvalues))
 482     (apply #'format strm (make-link-data-str obj view) refvalues)))
 483
 484 (defun obj-data (obj view)
 485   "Returns the objects data as a string. Used by common-graphics outline function"
 486   (awhen (obj-data-value-func view)
 487          (apply #'format nil (funcall (obj-data-fmtstr view))
 488                 (multiple-value-list (funcall it obj)))))
 489
 490 (defun make-link-data-str (obj view)
 491   "Return fmt string for that contains ~a slots for hyperlink link start and end"
 492   (awhen (obj-data-value-func view)
 493          (apply #'format nil (obj-data-fmtstr view)
 494                 (multiple-value-list (funcall it obj)))))
 495
 496 ;;; Display method for objects
 497
 498
 499 (defun load-all-subobjects (objs)
 500   "Load all subobjects if they have not already been loaded."
 501   (dolist (obj (mklist objs))
 502     (dolist (subobj (hyperobject-class-subobjects obj))
 503       (awhen (slot-value obj (name-slot subobj))
 504              (load-all-subobjects it))))
 505   objs)
 506
 507 (defun view-hyperobject (objs view category strm &optional (indent 0) filter
 508                          subobjects refvars)
 509   "Display a single or list of hyperobject-class instances and their subobjects"
 510   (let-when (objlist (mklist objs))
 511     (let ((nobjs (length objlist))
 512           (*print-pretty* nil)
 513           (*print-circle* nil)
 514           (*print-escape* nil)
 515           (*print-readably* nil)
 516           (*print-length* nil)
 517           (*print-level* nil))
 518       (fmt-list-start (car objlist) view strm indent nobjs)
 519       (dolist (obj objlist)
 520         (unless (and filter (not (funcall filter obj)))
 521           (fmt-obj-start obj view strm indent)
 522           (fmt-obj-data obj view strm (1+ indent) refvars)
 523           (when (and subobjects (hyperobject-class-subobjects obj))
 524             (dolist (subobj (hyperobject-class-subobjects obj))
 525               (aif (slot-value obj (name-slot subobj))
 526                    (view-hyperobject it (get-category-view (car (mklist it)) category)
 527                                      category strm (1+ indent) filter
 528                                      subobjects refvars))))
 529           (fmt-obj-end obj view strm indent)))
 530       (fmt-list-end (car objlist) view strm indent nobjs)))
 531   objs)
 532
 533
 534 (defun view (objs &key (stream *standard-output*) category view
 535              filter subobjects refvars file-wrapper)
 536   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
 537   (let-when (objlist (mklist objs))
 538     (when category
 539       (setq view (get-category-view (car objlist) category)))
 540     (unless view
 541       (setq view (default-view (class-of (car objlist)))))
 542     (when file-wrapper
 543       (fmt-file-start view stream))
 544     (view-hyperobject objlist view category stream 0 filter subobjects refvars)
 545     (when file-wrapper
 546       (fmt-file-end view stream)))
 547   objs)
 548
 549
 550 ;;; Misc formatting
 551
 552 (defun fmt-comma-integer (i)
 553   (format nil "~:d" i))
 554