cl-hyperobject 2.12.0-1 / usr / share / common-lisp / source / hyperobject / views.lisp

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:     views.lisp
;;;; Purpose:  View methods for Hyperobjects
;;;; Author:   Kevin M. Rosenberg
;;;; Created:  Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:hyperobject)


(defclass object-view ()
  ((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.")
   (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
                     :documentation "Country's Language for this view.")
   (printer :initform nil :initarg :printer :accessor printer
            :documentation "default function that prints the object")
   ;;
   (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-printer :type (or string function null) :initform nil
                           :initarg :list-start-printer
                      :accessor list-start-printer)
   (list-start-indent :initform nil :initarg :list-start-indent
                      :accessor list-start-indent)
   (list-end-printer :type (or string function null) :initform nil
                         :initarg :list-end-printer
                    :accessor list-end-printer)
   (list-end-indent :initform nil :initarg :list-end-indent
                    :accessor list-end-indent)
   (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
                     :accessor obj-start-printer)
   (obj-start-indent :initform nil :initarg :obj-start-indent
                     :accessor obj-start-indent)
   (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
                   :accessor obj-end-printer)
   (obj-end-indent :initform nil :initarg :obj-end-indent
                   :accessor obj-end-indent)
   (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
                     :accessor subobj-start-printer)
   (subobj-start-indent :initform nil :initarg :subobj-start-indent
                     :accessor subobj-start-indent)
   (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
                   :accessor subobj-end-printer)
   (subobj-end-indent :initform nil :initarg :subobj-end-indent
                   :accessor subobj-end-indent)
   (obj-data-indent :initform nil :initarg :obj-data-indent
                    :accessor obj-data-indent)
   (obj-data-printer :type (or function null) :initform nil
                        :initarg :obj-data-printer
                        :accessor obj-data-printer)
   (obj-data-print-code :type (or function list null) :initform nil
                  :initarg :obj-data-print-code
                  :accessor obj-data-print-code)
   (obj-data-start-printer :type (or function string null) :initform nil
                     :initarg :obj-data-start-printer
                     :accessor obj-data-start-printer)
   (obj-data-end-printer :type (or string null) :initform nil
                        :initarg :obj-data-end-printer
                        :accessor obj-data-end-printer)
   (indenter :type (or function null) :initform nil
             :accessor indenter
             :documentation "Function that performs hierarchical indenting")
   (link-slots :type list :initform nil
               :documentation "List of slot names that have hyperlinks"
               :accessor link-slots)
   (link-page :type (or string null) :initform nil
                      :initarg :link-page
                      :accessor link-page)
   (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 "meta-search.html")
  (:documentation "View class for a hyperobject"))

(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-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
;;;; *************************************************************************

(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))))
  (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"
  (cond
    ((typep view-def 'object-view)
     view-def)
    ((eq view-def :default)
     (make-instance 'object-view
       :object-class (class-name cl)
       :id :compact-text))
    ((consp view-def)
     (make-instance 'object-view
                    :object-class (class-name cl)
                    :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
                                       &allow-other-keys)
  (declare (ignore initargs))
  (initialize-view self))

(defun initialize-view (view)
  "Calculate all view slots for a hyperobject class"
  (let ((obj-cl (find-class (object-class view))))
    (cond
     ((source-code view)
      (initialize-view-by-source-code view))
     ((id view)
      (initialize-view-by-id obj-cl view))
     (t
      (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))
         (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)))))

(defmacro write-simple (v s)
  `(typecase ,v
    (string
     (write-string ,v ,s))
    (fixnum
     (write-fixnum ,v ,s))
    (symbol
     (write-string (symbol-name ,v) ,s))
    (t
     (write-string (write-to-string ,v) ,s))))

(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)))
    (if cdata
        (write-cdata fmt-data strm)
        (write-simple fmt-data strm))))

(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-display-table (title name type formatter cdata print-func)
  (vector-push-extend '(write-string "<td>" s) print-func)
  (ppfc-html title name type formatter cdata print-func)
  (vector-push-extend '(write-string "</td>" 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 `(when (stringp ,label) (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 `(when (stringp ,label) (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 `(when (stringp ,label) (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)
  (declare (fixnum nlink))
  (vector-push-extend '(write-char #\< s) print-func)
  (vector-push-extend `(when (stringp (nth ,(+ nlink nlink) links))
                         (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 `(when (stringp (nth ,(+ nlink nlink 1) links))
                         (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 "<span class=\"label\">" s) print-func)
  (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
  (vector-push-extend '(write-string "</span> " s) print-func)
  (ppfc-html-link name type formatter cdata 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))
         (xml-user-name (escape-xml-string user-name))
         (xml-tag (escape-xml-string user-name))
         (type (slot-definition-type slot))

         (cdata (not (null
                      (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)
                           (or formatter
                               (lisp-type-is-a-string type))))))
         (hyperlink (esd-hyperlink slot)))

    (case vid
      (:compact-text
       (vector-push-extend
        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
      (:compact-text-labels
       (vector-push-extend `(write-string ,user-name 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 user-name name type formatter cdata print-func))
      (:xml
       (ppfc-xml xml-tag name type formatter cdata print-func))
      (:html-labels
       (ppfc-html-labels user-name name type formatter cdata print-func))
      (:xhtml-labels
       (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
      ((:display-table :display-table-labels)
       (ppfc-display-table user-name name type formatter cdata print-func))
      (:xml-labels
       (ppfc-xml-labels xml-user-name 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 user-name 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-link-labels user-name name type formatter cdata nlink
                                  print-func)
           (ppfc-html-labels user-name name type formatter cdata print-func)))
      (:xhtml-link-labels
       (if hyperlink
           (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
                                  print-func)
           (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
                              print-func)))
      ((or :xml-link-labels :ie-xml-link-labels)
       (if hyperlink
           (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
                                  print-func)
           (ppfc-xml-labels xml-tag user-name name type formatter cdata
                            print-func))))))


(defun view-has-links-p (view)
  (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 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 :display-table-labels :edit-table :edit-table-labels))

(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)))

  (let ((links '())
        (print-func (make-array 20 :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 (id 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)))

    (vector-push-extend 'x print-func) ;; return object
    (setf (obj-data-print-code view) `(lambda (x s links)
                                       (declare (ignorable s links))
                                       ,@(map 'list #'identity print-func)))
    (setf (obj-data-printer view)
          (compile nil (eval (obj-data-print-code view))))

    (setf (link-slots view) (nreverse links)))

  (finalize-view-by-id view)
  view)

(defun finalize-view-by-id (view)
  (case (id view)
    ((or :compact-text :compact-text-labels)
     (initialize-text-view view))
    ((or :html :html-labels)
     (initialize-html-view view))
    ((or :xhtml :xhtml-labels)
     (initialize-xhtml-view view))
    ((or :xml :xml-labels)
     (initialize-xml-view view))
    ((or :html-link :html-link-labels)
     (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-xhtml-view view)
     (setf (link-href-start view) "a href=")
     (setf (link-href-end view) "a")
     (setf (link-ampersand view) "&amp;"))
    ((or :display-table :display-table-labels :edit-tables)
     (initialize-table-view view)
     (when (in (id view) :display-table-labels :edit-table-labels)
       (setf (list-start-printer view) #'table-label-list-start-func))
     (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 Data Format Section
;;;; *************************************************************************

(defun class-name-of (obj)
  (string-downcase (class-name (class-of obj))))

(defvar +newline-string+ (format nil "~%"))

(defun write-user-name-maybe-plural (obj nitems strm)
  (write-string
   (if (> nitems 1)
       (hyperobject-class-user-name-plural obj)
       (hyperobject-class-user-name obj))
   strm))

(defun initialize-text-view (view)
  (setf (list-start-printer view)
        (compile nil
                 (eval '(lambda (obj nitems indent strm)
                         (declare (ignore indent))
                         (write-user-name-maybe-plural obj nitems strm)
                         (write-char #\: strm)
                         (write-char #\Newline strm)))))
  (setf (list-start-indent view) t)
  (setf (obj-data-indent view) t)
  (setf (obj-data-end-printer view) +newline-string+)
  (setf (indenter view) #'indent-spaces))

(defun html-list-start-func (obj nitems indent strm)
  (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-user-name-maybe-plural obj nitems strm)
  (write-string "</div>" strm)
  (write-char #\newline strm)
  (write-string "<ul>" strm)
  (write-char #\newline strm))

(defun initialize-html-view (view)
  (initialize-text-view view)
  (setf (indenter view) #'indent-spaces)
  (setf (file-start-str view) (format nil "<html><body>~%"))
  (setf (file-end-str view) (format nil "</body><html>~%"))
  (setf (list-start-indent view) t)
  (setf (list-start-printer view) #'html-list-start-func)
  (setf (list-end-printer view) (format nil "</ul>~%"))
  (setf (list-end-indent view) t)
  (setf (obj-start-indent view) nil)
  (setf (obj-start-printer view) "<li>")
  (setf (obj-end-indent view)  nil)
  (setf (obj-end-printer view)  (format nil "</li>~%"))
  (setf (obj-data-end-printer view) nil)
  (setf (obj-data-indent view) nil))

(defun xhtml-list-start-func (obj nitems indent strm)
  (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-user-name-maybe-plural obj nitems strm)
  (write-string "</div>" strm)
  (write-string "<div style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-char #\newline strm))

(defun table-list-start-func (obj nitems indent strm)
  (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-user-name-maybe-plural obj nitems strm)
  (write-string "</div>" strm)
  (write-char #\newline strm)
  (write-string "<table style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-string "<tbody>" strm)
  (write-char #\newline strm))

(defun table-label-list-start-func (obj nitems indent strm)
  (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-user-name-maybe-plural obj nitems strm)
  (write-string "</div>" strm)
  (write-char #\newline strm)
  (write-string "<table style=\"margin-left:" strm)
  (write-fixnum (+ indent indent) strm)
  (write-string "em;\">" strm)
  (write-string "<thead>" strm)
  (dolist (slot (default-print-slots (class-of obj)))
    (write-string "<th>" strm)
    (write-string (write-to-string slot) strm)
    (write-string "</th>" strm))
  (write-string "</thead>" strm)
  (write-char #\newline strm)
  (write-string "<tbody>" strm)
  (write-char #\newline strm))

(defun html-obj-start (obj indent strm)
  (declare (ignore obj indent))
  (write-string "<div style=\"margin-left:2em;\">" strm))

(defun initialize-xhtml-view (view)
  (initialize-text-view view)
  (setf (indenter view) #'indent-spaces)
  (setf (file-start-str view) (format nil "<html><body>~%"))
  (setf (file-end-str view) (format nil "</body><html>~%"))
  (setf (list-start-indent view) nil)
  (setf (list-start-printer view) #'xhtml-list-start-func)
  (setf (list-end-printer view) (format nil "</div>~%"))
  (setf (list-end-indent view) nil)
  (setf (obj-start-indent view) nil)
  (setf (obj-start-printer view) #'html-obj-start)
  (setf (obj-end-printer view) (format nil "</div>~%"))
  (setf (obj-data-indent view) nil))

(defun initialize-table-view (view)
  (initialize-text-view view)
  (setf (indenter view) #'indent-spaces)
  (setf (file-start-str view) (format nil "<html><body>~%"))
  (setf (file-end-str view) (format nil "</body><html>~%"))
  (setf (list-start-indent view) nil)
  (setf (list-start-printer view) #'table-list-start-func)
  (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
  (setf (list-end-indent view) nil)
  (setf (obj-start-indent view) nil)
  (setf (obj-start-printer view) #'html-obj-start)
  (setf (obj-start-printer view) (format nil "<tr>"))
  (setf (obj-end-printer view) (format nil "</tr>~%"))
  (setf (obj-data-indent view) nil))

(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 indent strm)
  (declare (ignore indent))
  (write-char #\< strm)
  (write-string (class-name-of x) strm)
  (write-string "list><title>" strm)
  (write-user-name-maybe-plural x nitems strm)
  (write-string ":</title>" strm)
  (write-char #\newline strm))

(defun initialize-xml-view (view)
  (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 (obj-end-printer view) (format nil "</~(~a~)>~%" name))
    (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

(defun fmt-file-start (view strm)
  (awhen (file-start-str view)
         (write-string it strm)))

(defun fmt-file-end (view strm)
  (awhen (file-end-str view)
         (write-string it strm)))

;;; List Start and Ends

(defun fmt-list-start (obj view strm indent num-items)
  (when (list-start-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (list-start-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj num-items indent strm))))

(defun fmt-list-end (obj view strm indent num-items)
  (declare (ignore num-items))
  (when (list-end-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (list-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))

;;; Object Start and Ends


(defun fmt-obj-start (obj view strm indent)
  (when (obj-start-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (obj-start-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj indent strm))))

(defun fmt-obj-end (obj view strm indent)
  (when (obj-end-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (obj-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))

(defun fmt-subobj-start (obj view strm indent)
  (when (subobj-start-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (subobj-start-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj indent strm))))

(defun fmt-subobj-end (obj view strm indent)
  (when (subobj-end-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (awhen (subobj-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))

;;; Object Data


(defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
  (with-output-to-string (s)
    (write-string (link-href-start view) s)
    (write-char #\" s)
    (let ((link-page (link-page view)))
      (cond
        ((null link-printer)
         (write-string (make-url link-page) s)
         (write-string "?func=" s)
         (write-simple fieldfunc s)
         (write-string (link-ampersand view) s)
         (write-string "key=" s)
         (write-simple fieldvalue s)
         (dolist (var refvars)
           (write-string (link-ampersand view) s)
           (write-simple (car var) s)
           (write-char #\= s)
           (write-simple (cdr var) s)))
        (link-printer
         (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
    (write-char #\" s)))

(defun make-link-end (obj view fieldname)
  (declare (ignore obj fieldname))
  (link-href-end view))

(defun fmt-obj-data (obj view strm indent refvars link-printer)
  (awhen (obj-data-start-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm)))
  (when (obj-data-indent view)
    (awhen (indenter view)
           (funcall it indent strm)))
  (if (link-slots view)
      (fmt-obj-data-with-link obj view strm refvars link-printer)
      (fmt-obj-data-plain obj view strm))
  (awhen (obj-data-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))

(defun fmt-obj-data-plain (obj view strm)
  (awhen (obj-data-printer view)
         (funcall it obj strm nil)))

(defun fmt-obj-data-with-link (obj view strm refvars link-printer)
  (let ((refvalues '()))
    (declare (dynamic-extent refvalues))
    ;; make list of hyperlink link fields for printing to refstr template
    (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)
                                    link-printer)
                   refvalues)
             (push (make-link-end obj view name) refvalues)))
    (funcall (obj-data-printer view) obj strm (nreverse refvalues))))

(defun obj-data (obj view)
  "Returns the objects data as a string. Used by common-graphics outline function"
  (with-output-to-string (s) (fmt-obj-data-plain obj view s)))

;;; Display method for objects


(defun load-all-subobjects (objs)
  "Load all subobjects if they have not already been loaded."
  (dolist (obj (mklist objs))
    (dolist (subobj (hyperobject-class-subobjects obj))
      (awhen (slot-value obj (name-slot subobj))
             (load-all-subobjects it))))
  objs)

(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-view-id (car (mklist it)) vid)
            strm vid (1+ indent) filter subobjects refvars
            link-printer)))))


(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))
    (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 (printer view)
               (funcall it obj strm))
        (unless (and filter (not (funcall filter obj)))
          (fmt-obj-start obj view strm indent)
          (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
          (fmt-obj-end obj view strm indent)
          (if subobjects
              (progn
                (fmt-subobj-start obj view strm indent)
                (view-subobjects obj strm vid indent filter subobjects
                                 refvars link-printer)
                (fmt-subobj-end obj view strm indent))
            (fmt-subobj-start obj view strm indent))))
      (fmt-list-end (car objlist) view strm indent nobjs)))
  objs)


(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))
    (unless view
      (setq view (get-view-id (car objlist) vid)))
    (when file-wrapper
      (fmt-file-start view stream))
    (view-hyperobject objlist view stream vid 0 filter subobjects refvars
                      link-printer)
    (when file-wrapper
      (fmt-file-end view stream)))
  objs)


;;; Misc formatting

(defun fmt-comma-integer (i)
  (format nil "~:d" i))