X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=views.lisp;h=7a464d9df02ad3388fa492536c029c945e70fe0e;hp=4b0867e0ca5ec3b19cb40e2f9467a9f6854ef654;hb=84f0745468d57540f972b31c230f1ccae2bc1768;hpb=fb79a796c6ff0b90aedc377a804b48a7b543f65b diff --git a/views.lisp b/views.lisp index 4b0867e..7a464d9 100644 --- a/views.lisp +++ b/views.lisp @@ -7,34 +7,28 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.47 2003/05/22 21:03:52 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(in-package #:hyperobject) (defclass object-view () - ((object-class-name :initform nil :initarg :object-class-name - :accessor object-class-name - :documentation "Name of class of object to be viewed.") - (object-class :initform nil :initarg :object-class + ((object-class :initform nil :initarg :object-class :accessor object-class :documentation "Class of object to be viewed.") (slots :initform nil :initarg :slots :accessor slots :documentation "List of effective slots for object to be viewed.") - (name :initform nil :initarg :name :accessor name - :documentation "Name for this view.") - (category :initform nil :initarg :category :accessor category - :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") + (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) @@ -58,6 +52,14 @@ :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 @@ -66,40 +68,67 @@ (obj-data-print-code :type (or function null) :initform nil :initarg :obj-data-print-code :accessor obj-data-print-code) - (obj-data-end-str :type (or string null) :initform nil - :initarg :obj-data-end-str - :accessor obj-data-end-str) + (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-name :type (or string null) :initform nil :initarg :link-page-name - :accessor link-page-name) + (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-name "disp-func1") + (:default-initargs :link-page "lookup-func1") (: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-name (class-name obj-class) - :object-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 ;;;; ************************************************************************* @@ -109,17 +138,9 @@ (unless (default-print-slots cl) (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) - (let ((views '())) - (dolist (view-def (views cl)) - (push (make-object-view cl view-def) views)) - (setf (views cl) (nreverse views))) - (cond - ((default-view cl) - (setf (default-view cl) (make-object-view cl (default-view cl)))) - ((car (views cl)) - (setf (default-view cl) (make-object-view cl (car (views cl))))) - (t - (setf (default-view cl) (make-object-view cl :default))))) + (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" @@ -127,46 +148,64 @@ ((typep view-def 'object-view) view-def) ((eq view-def :default) - (let* ((name (class-name cl)) - (view (make-instance 'object-view :name "automatic" - :object-class-name name - :object-class cl - :category :compact-text))) - view)) + (make-instance 'object-view + :object-class (class-name cl) + :id :compact-text)) ((consp view-def) - (apply #'make-instance 'object-view 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 ((view object-view) - &rest initargs &key &allow-other-keys) - (initialize-view (object-class view) view)) +(defmethod initialize-instance :after ((self object-view) + &rest initargs + &key + &allow-other-keys) + (initialize-view self)) -(defun initialize-view (obj-cl view) +(defun initialize-view (view) "Calculate all view slots for a hyperobject class" - (cond - ((category view) - (initialize-view-by-category obj-cl view)) - ((source-code view) - (initialize-view-by-source-code obj-cl view)) - (t - (setf (category view) :compact-text) - (initialize-view-by-category obj-cl view)))) + (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 (obj-cl view) +(defun initialize-view-by-source-code (view) "Initialize a view based upon a source code" - (let ((source-code (source-code view))) - (error "not implemented") - ) - ) + (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)) - #+allegro (fixnum - (excl::print-fixnum ,s 10 ,v)) + (write-fixnum ,v ,s)) (symbol (write-string (symbol-name ,v) ,s)) (t @@ -177,12 +216,10 @@ (let* ((slot-data (slot-value obj name)) (fmt-data (if formatter (funcall formatter slot-data) - slot-data)) - (data (if cdata - (kmrcl:xml-cdata fmt-data) - fmt-data))) - (write-simple data strm))) - + 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 " s) print-func)) (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) - (vector-push-extend '(write-string " " s) print-func) + (vector-push-extend '(write-string " " 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)) - (namestr-lower (string-downcase (symbol-name name))) - (xml-namestr (escape-xml-string namestr-lower)) - (xml-tag (escape-xml-string namestr-lower)) + (user-name (esd-user-name slot)) + (xml-user-name (escape-xml-string user-name)) + (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) @@ -250,66 +287,72 @@ (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)) (:compact-text-labels - (vector-push-extend `(write-string ,namestr-lower s) print-func) + (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 namestr-lower name type formatter cdata print-func)) + (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 namestr-lower name type formatter cdata print-func)) + (ppfc-html-labels user-name name type formatter cdata print-func)) (:xhtml-labels - (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func)) + (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) (:xml-labels - (ppfc-xml-labels xml-namestr xml-tag name type formatter cdata print-func)) + (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 namestr-lower name type formatter cdata 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 namestr-lower name type formatter cdata nlink + (ppfc-html-link-labels user-name name type formatter cdata nlink print-func) - (ppfc-html-labels namestr-lower name type formatter cdata print-func))) + (ppfc-html-labels user-name name type formatter cdata print-func))) (:xhtml-link-labels (if hyperlink - (ppfc-html-link-labels xml-namestr name type formatter cdata nlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) - (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata + (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-namestr name type formatter cdata nlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) - (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata + (ppfc-xml-labels xml-tag user-name name type formatter cdata print-func)))))) (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) - (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))) @@ -324,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)) @@ -333,22 +376,24 @@ (vector-push-extend 'x print-func) ;; return object (setf (obj-data-print-code view) `(lambda (x s links) - (declare (ignorable 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-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 :xhtml :html-labels :xhtml-labels) + ((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) @@ -357,7 +402,7 @@ (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) ((or :xhtml-link :xhtml-link-labels) - (initialize-html-view view) + (initialize-xhtml-view view) (setf (link-href-start view) "a href=") (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) @@ -393,48 +438,69 @@ (defun initialize-text-view (view) (setf (list-start-printer view) (compile nil - (eval '(lambda (obj nitems strm) + (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-str view) +newline-string+)) + (setf (obj-data-end-printer view) +newline-string+) + (setf (indenter view) #'indent-spaces)) -(defun html-list-start-func (obj nitems strm) - (write-string "

" strm) +(defun html-list-start-func (obj nitems indent strm) + (write-string "

" strm) (write-user-name-maybe-plural obj nitems strm) - (write-string ":

" strm) + (write-char #\newline strm) + (write-string "
~%")) + (setf (list-end-printer view) (format nil "~%")) (setf (list-end-indent view) t) - (setf (obj-start-indent view) t) + (setf (obj-start-indent view) nil) (setf (obj-start-printer view) "
  • ") - (setf (obj-end-indent view) t) + (setf (obj-end-indent view) nil) (setf (obj-end-printer view) (format nil "
    • ~%")) + (setf (obj-data-end-printer view) nil) (setf (obj-data-indent view) nil)) +(defun xhtml-list-start-func (obj nitems indent strm) + (write-string "
    " strm) + (write-user-name-maybe-plural obj nitems strm) + (write-string "
    " strm) + (write-string "
    " strm) + (write-char #\newline strm)) + +(defun html-obj-start (obj indent strm) + (declare (ignore obj indent)) + (write-string "
    " strm)) + (defun initialize-xhtml-view (view) (initialize-text-view view) + (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) - (setf (list-start-indent view) t) - (setf (list-start-printer view) #'html-list-start-func) - (setf (list-end-printer view) (format nil "
    ~%")) - (setf (list-end-indent view) t) - (setf (obj-start-indent view) t) - (setf (obj-start-printer view) "
  • ") - (setf (obj-end-indent view) t) - (setf (obj-end-printer view) (format nil "
    • ~%")) + (setf (list-start-indent view) nil) + (setf (list-start-printer view) #'xhtml-list-start-func) + (setf (list-end-printer view) (format nil "
    ~%")) + (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 "~%")) (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) @@ -444,7 +510,8 @@ (write-string ">" strm) (write-char #\newline strm)) -(defun xmlformat-list-start-func (x nitems 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>" strm) @@ -453,17 +520,17 @@ (write-char #\newline strm)) (defun initialize-xml-view (view) - (initialize-text-view view) - (setf (file-start-str view) "") ; (std-xml-header) - (setf (list-start-indent view) t) - (setf (list-start-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 (obj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view))) - (setf (obj-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 @@ -480,16 +547,18 @@ (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (list-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj num-items 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) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (list-end-printer view) (if (stringp it) (write-string it strm) @@ -497,66 +566,101 @@ ;;; Object Start and Ends + (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj strm)))) + (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) - (indent-spaces indent strm)) + (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) +(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) - (write-string (make-url (link-page-name view)) 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)) + (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) +(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) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (if (link-slots view) - (fmt-obj-data-with-link obj view strm refvars) + (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) - (awhen (obj-data-end-str view) - (write-string it 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) +(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)) + (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)))) @@ -576,10 +680,20 @@ (load-all-subobjects it)))) objs) -(defun view-hyperobject (objs view category strm &optional (indent 0) filter - subobjects refvars) +(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" - (declare (fixnum indent)) (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) (*print-pretty* nil) @@ -590,31 +704,31 @@ (*print-level* nil)) (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) - (unless (and filter (not (funcall filter obj))) - (fmt-obj-start obj view strm indent) - (fmt-obj-data obj view strm (1+ indent) refvars) - (when (and subobjects (hyperobject-class-subobjects obj)) - (dolist (subobj (hyperobject-class-subobjects obj)) - (aif (slot-value obj (name-slot subobj)) - (view-hyperobject it (get-category-view (car (mklist it)) category) - category strm (1+ indent) filter - subobjects refvars)))) - (fmt-obj-end obj view strm indent))) + (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) + (when subobjects + (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-list-end (car objlist) view strm indent nobjs))) objs) -(defun view (objs &key (stream *standard-output*) category view - filter subobjects refvars file-wrapper) - "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject" +(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 category stream 0 filter subobjects refvars) + (view-hyperobject objlist view stream vid 0 filter subobjects refvars + link-printer) (when file-wrapper (fmt-file-end view stream))) objs)