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