;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: views.lisp
;;;; Purpose: View methods for Hyperobjects
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; $Id: views.lisp,v 1.4 2002/11/29 23:14:31 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
;;;; *************************************************************************
;;;; Metaclass Intialization
;;;; *************************************************************************
(defun process-views (cl)
"Calculate all view slots for a hyperobject class"
(let ((fmtstr-text "")
(fmtstr-html "")
(fmtstr-xml "")
(fmtstr-text-labels "")
(fmtstr-html-labels "")
(fmtstr-xml-labels "")
(fmtstr-html-ref "")
(fmtstr-xml-ref "")
(fmtstr-html-ref-labels "")
(fmtstr-xml-ref-labels "")
(first-field t)
(value-func '())
(xmlvalue-func '())
(classname (class-name cl))
(package (symbol-package (class-name cl)))
(hyperlinks nil))
(declare (ignore classname))
(check-type (slot-value cl 'print-slots) list)
(dolist (slot-name (slot-value cl 'print-slots))
(let ((slot (find-slot-by-name cl slot-name)))
(unless slot
(error "Slot ~A is not found in class ~S" slot-name cl))
(let ((name (slot-definition-name slot))
(namestr (symbol-name (slot-definition-name slot)))
(namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
(type (slot-value slot 'ho-type))
(print-formatter (slot-value slot 'print-formatter))
(value-fmt "~a")
(plain-value-func nil)
html-str xml-str html-label-str xml-label-str)
(when (or (eql type :integer) (eql type :fixnum))
(setq value-fmt "~d"))
(when (eql type :boolean)
(setq value-fmt "~a"))
(if first-field
(setq first-field nil)
(progn
(string-append fmtstr-text " ")
(string-append fmtstr-html " ")
(string-append fmtstr-xml " ")
(string-append fmtstr-text-labels " ")
(string-append fmtstr-html-labels " ")
(string-append fmtstr-xml-labels " ")
(string-append fmtstr-html-ref " ")
(string-append fmtstr-xml-ref " ")
(string-append fmtstr-html-ref-labels " ")
(string-append fmtstr-xml-ref-labels " ")))
(setq html-str (concatenate 'string "" value-fmt ""))
(setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "" namestr-lower ">"))
(setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt ""))
(setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "" namestr-lower ">"))
(string-append fmtstr-text value-fmt)
(string-append fmtstr-html html-str)
(string-append fmtstr-xml xml-str)
(string-append fmtstr-text-labels namestr-lower " " value-fmt)
(string-append fmtstr-html-labels html-label-str)
(string-append fmtstr-xml-labels xml-label-str)
(if (slot-value slot 'hyperlink)
(progn
(string-append fmtstr-html-ref "<~~a>" value-fmt "~~a>")
(string-append fmtstr-xml-ref "<~~a>" value-fmt "~~a>")
(string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "~~a>")
(string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "~~a>")
(push (make-instance 'hyperlink :name name
:lookup (slot-value slot 'hyperlink))
hyperlinks))
(progn
(string-append fmtstr-html-ref html-str)
(string-append fmtstr-xml-ref xml-str)
(string-append fmtstr-html-ref-labels html-label-str)
(string-append fmtstr-xml-ref-labels xml-label-str)))
(if print-formatter
(setq plain-value-func
(list `(,print-formatter (slot-value x ',(intern namestr package)))))
(setq plain-value-func
(list `(slot-value x ',(intern namestr package)))))
(setq value-func (append value-func plain-value-func))
(if (eql type :cdata)
(setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
(setq xmlvalue-func (append xmlvalue-func plain-value-func)))
)))
(setf (slot-value cl 'hyperlinks) hyperlinks)
(if value-func
(setq value-func `(lambda (x) (values ,@value-func)))
(setq value-func `(lambda () (values))))
(setq value-func (compile nil (eval value-func)))
(if xmlvalue-func
(setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
(setq xmlvalue-func `(lambda () (values))))
(setq xmlvalue-func (compile nil (eval xmlvalue-func)))
(setf (slot-value cl 'fmtstr-text) fmtstr-text)
(setf (slot-value cl 'fmtstr-html) fmtstr-html)
(setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
(setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
(setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
(setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
(setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
(setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
(setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
(setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
(setf (slot-value cl 'value-func) value-func)
(setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
(values))
;;;; *************************************************************************
;;;; View Data Format Section
;;;; *************************************************************************
(defparameter *default-textformat* nil)
(defparameter *default-htmlformat* nil)
(defparameter *default-htmlrefformat* nil)
(defparameter *default-xhtmlformat* nil)
(defparameter *default-xhtmlrefformat* nil)
(defparameter *default-xmlformat* nil)
(defparameter *default-xmlrefformat* nil)
(defparameter *default-ie-xmlrefformat* nil)
(defparameter *default-nullformat* nil)
(defparameter *default-init-format?* nil)
(defun make-format-instance (fmt)
(unless *default-init-format?*
(setq *default-textformat* (make-instance 'textformat))
(setq *default-htmlformat* (make-instance 'htmlformat))
(setq *default-htmlrefformat* (make-instance 'htmlrefformat))
(setq *default-xhtmlformat* (make-instance 'xhtmlformat))
(setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
(setq *default-xmlformat* (make-instance 'xmlformat))
(setq *default-xmlrefformat* (make-instance 'xmlrefformat))
(setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
(setq *default-nullformat* (make-instance 'nullformat))
(setq *default-init-format?* t))
(case fmt
(:text *default-textformat*)
(:html *default-htmlformat*)
(:htmlref *default-htmlrefformat*)
(:xhtml *default-xhtmlformat*)
(:xhtmlref *default-xhtmlrefformat*)
(:xml *default-xmlformat*)
(:xmlref *default-xmlrefformat*)
(:ie-xmlref *default-ie-xmlrefformat*)
(:null *default-nullformat*)
(otherwise *default-textformat*)))
;;;; Output format classes for print hyperobject-classes
(defclass dataformat ()
((file-start-str :type string :initarg :file-start-str :reader file-start-str)
(file-end-str :type string :initarg :file-end-str :reader file-end-str)
(list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
(list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
(list-start-indent :initarg :list-start-indent :reader list-start-indent)
(list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
(list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
(list-end-indent :initarg :list-end-indent :reader list-end-indent)
(obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
(obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
(obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
(obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
(obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
(obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
(obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
(obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr)
(obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels)
(obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
(obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
(link-ref :initarg :link-ref :reader link-ref))
(:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
:list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
:obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
:obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
:obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
:obj-data-value-func nil :link-ref nil)
(:documentation "Parent for all dataformat objects"))
(defclass binaryformat (dataformat)
())
(defclass nullformat (dataformat)
())
(defun text-list-start-value-func (obj nitems)
(values (hyperobject-class-title obj) nitems))
(defclass textformat (dataformat)
()
(:default-initargs :list-start-fmtstr "~a~P:~%"
:list-start-value-func #'text-list-start-value-func
:list-start-indent t
:obj-data-indent t
:obj-data-fmtstr #'hyperobject-class-fmtstr-text
:obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
:obj-data-end-fmtstr "~%"
:obj-data-value-func #'hyperobject-class-value-func))
(defun class-name-of (obj)
(string-downcase (class-name (class-of obj))))
(defun htmlformat-list-start-value-func (x nitems)
(values (hyperobject-class-title x) nitems (class-name-of x)))
(defclass htmlformat (textformat)
()
(:default-initargs :file-start-str "
~%"
:file-end-str "~%"
:list-start-indent t
:list-start-fmtstr "~a~p:
~%"
:list-start-value-func #'htmlformat-list-start-value-func
:list-end-fmtstr "
~%"
:list-end-indent t
:list-end-value-func #'identity
:obj-start-indent t
:obj-start-fmtstr ""
:obj-start-value-func #'identity
:obj-end-indent t
:obj-end-fmtstr "~%"
:obj-end-value-func #'identity
:obj-data-indent t
:obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
:obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
:obj-data-value-func #'hyperobject-class-value-func))
(defclass xhtmlformat (textformat)
()
(:default-initargs :file-start-str "~%"
:file-end-str "~%"
:list-start-indent t
:list-start-fmtstr "~a~p:
~%"
:list-start-value-func #'htmlformat-list-start-value-func
:list-end-fmtstr "
~%"
:list-end-indent t
:list-end-value-func #'identity
:obj-start-indent t
:obj-start-fmtstr ""
:obj-start-value-func #'identity
:obj-end-indent t
:obj-end-fmtstr "~%"
:obj-end-value-func #'identity
:obj-data-indent t
:obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
:obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
:obj-data-value-func #'hyperobject-class-xmlvalue-func))
(defun xmlformat-list-end-value-func (x)
(format nil "~alist" (class-name-of x)))
(defun xmlformat-list-start-value-func (x nitems)
(values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
(defclass xmlformat (textformat)
()
(:default-initargs :file-start-str "" ; (std-xml-header)
:list-start-indent t
:list-start-fmtstr "<~a>~a~p: ~%"
:list-start-value-func #'xmlformat-list-start-value-func
:list-end-indent t
:list-end-fmtstr "~a>~%"
:list-end-value-func #'xmlformat-list-end-value-func
:obj-start-fmtstr "<~a>"
:obj-start-value-func #'class-name-of
:obj-start-indent t
:obj-end-fmtstr "~a>~%"
:obj-end-value-func #'class-name-of
:obj-end-indent nil
:obj-data-indent nil
:obj-data-fmtstr #'hyperobject-class-fmtstr-xml
:obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
:obj-data-value-func #'hyperobject-class-xmlvalue-func))
(defclass link-ref ()
((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
(fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
(page-name :type string :initarg :page-name :accessor page-name)
(href-head :type string :initarg :href-head :accessor href-head)
(href-end :type string :initarg :href-end :accessor href-end)
(ampersand :type string :initarg :ampersand :accessor ampersand))
(:default-initargs :fmtstr nil
:fmtstr-labels nil
:page-name "disp-func1"
:href-head nil :href-end nil :ampersand nil)
(:documentation "Formatting for a linked hyperlink"))
(defclass html-link-ref (link-ref)
()
(:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
:fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
:href-head "a href="
:href-end "a"
:ampersand "&"))
(defclass xhtml-link-ref (link-ref)
()
(:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
:fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
:href-head "a href="
:href-end "a"
:ampersand "&"))
(defclass xml-link-ref (link-ref)
()
(:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
:fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
:href-head "xmllink xlink:type=\"simple\" xlink:href="
:href-end "xmllink"
:ampersand "&")
(:documentation "Mozilla's and W3's idea of a link with XML"))
(defclass ie-xml-link-ref (xml-link-ref)
()
(:default-initargs :href-head "html:a href="
:href-end "html:a" )
(:documentation "Internet Explorer's idea of a link with XML"))
(defclass htmlrefformat (htmlformat)
()
(:default-initargs :link-ref (make-instance 'html-link-ref)))
(defclass xhtmlrefformat (xhtmlformat)
()
(:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
(defclass xmlrefformat (xmlformat)
()
(:default-initargs :link-ref (make-instance 'xml-link-ref)))
(defclass ie-xmlrefformat (xmlformat)
()
(:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
;;; File Start and Ends
(defgeneric fmt-file-start (fmt s))
(defmethod fmt-file-start ((fmt dataformat) (s stream)))
(defmethod fmt-file-start ((fmt textformat) (s stream))
(aif (file-start-str fmt)
(format s it)))
(defgeneric fmt-file-end (fmt s))
(defmethod fmt-file-end ((fmt textformat) (s stream))
(aif (file-end-str fmt)
(format s it)))
;;; List Start and Ends
(defgeneric fmt-list-start (obj fmt s &optional indent num-items))
(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
(if (list-start-indent fmt)
(indent-spaces indent s))
(aif (list-start-fmtstr fmt)
(apply #'format s it
(multiple-value-list
(funcall (list-start-value-func fmt) x num-items)))))
(defgeneric fmt-list-end (obj fmt s &optional indent num-items))
(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
(declare (ignore num-items))
(if (list-end-indent fmt)
(indent-spaces indent s))
(aif (list-end-fmtstr fmt)
(apply #'format s it
(multiple-value-list
(funcall (list-end-value-func fmt) x)))))
;;; Object Start and Ends
(defgeneric fmt-obj-start (obj fmt s &optional indent))
(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
(if (obj-start-indent fmt)
(indent-spaces indent s))
(aif (obj-start-fmtstr fmt)
(apply #'format s it
(multiple-value-list
(funcall (obj-start-value-func fmt) x)))))
(defgeneric fmt-obj-end (obj fmt s &optional indent))
(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
(if (obj-end-indent fmt)
(indent-spaces indent s))
(aif (obj-end-fmtstr fmt)
(apply #'format s it
(multiple-value-list
(funcall (obj-end-value-func fmt) x)))))
;;; Object Data
(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
(declare (ignore obj fieldname))
(format nil "~a\"~a?func=~a~akey=~a~a\""
(href-head ref) (make-url (page-name ref)) fieldfunc
(ampersand ref) fieldvalue
(if refvars
(let ((varstr ""))
(dolist (var refvars)
(string-append varstr (format nil "~a~a=~a"
(ampersand ref) (car var) (cadr var))))
varstr)
"")))
(defgeneric make-link-end (obj ref fieldname))
(defmethod make-link-end (obj (ref link-ref) fieldname)
(declare (ignore obj fieldname))
(format nil "~a" (href-end ref))
)
(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
(defmethod fmt-obj-data (x (fmt textformat) s
&optional (indent 0) (label nil) (refvars nil))
(if (obj-data-indent fmt)
(indent-spaces indent s))
(if (link-ref fmt)
(fmt-obj-data-with-ref x fmt s label refvars)
(fmt-obj-data-plain x fmt s label))
(aif (obj-data-end-fmtstr fmt)
(format s it)))
(defgeneric fmt-obj-data-plain (obj fmt s label))
(defmethod fmt-obj-data-plain (x (fmt textformat) s label)
(if label
(apply #'format s
(funcall (obj-data-fmtstr-labels fmt) x)
(multiple-value-list
(funcall (funcall (obj-data-value-func fmt) x) x)))
(apply #'format s (funcall (obj-data-fmtstr fmt) x)
(multiple-value-list
(funcall (funcall (obj-data-value-func fmt) x) x)))))
(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
(let ((refstr (make-ref-data-str x fmt label))
(refvalues nil)
(field-values
(multiple-value-list
(funcall (funcall (obj-data-value-func fmt) x) x))))
;; make list of hyperlink link fields for printing to refstr template
(dolist (ref (hyperobject-class-hyperlinks x))
(let ((link-start
(make-link-start x (link-ref fmt) (name ref) (lookup ref)
(nth (position (name ref)
(hyperobject-class-fields x)
:key #'(lambda (x)
(slot-definition-name x)))
field-values)
(append (link-parameters ref) refvars)))
(link-end (make-link-end x (link-ref fmt) (name ref))))
(push link-start refvalues)
(push link-end refvalues)))
(setq refvalues (nreverse refvalues))
(apply #'format s refstr refvalues)))
(defgeneric obj-data (obj))
(defmethod obj-data (x)
"Returns the objects data as a string. Used by common-graphics outline function"
(let ((fmt (make-format-instance :text)))
(apply #'format nil (funcall (obj-data-fmtstr fmt) x)
(multiple-value-list
(funcall (funcall (obj-data-value-func fmt) x) x)))))
(defgeneric make-ref-data-str (obj fmt &optional label))
(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
"Return fmt string for that contains ~a slots for hyperlink link start and end"
(unless (link-ref fmt)
(error "fmt does not contain a link-ref"))
(let ((refstr
(if label
(apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
(multiple-value-list
(funcall (funcall (obj-data-value-func fmt) x) x)))
(apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
(multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
refstr))
;;; Display method for objects
(defgeneric load-all-subobjects (objs))
(defmethod load-all-subobjects (objs)
"Load all subobjects if they have not already been loaded."
(when objs
(let ((objlist (mklist objs)))
(dolist (obj objlist)
(awhen (hyperobject-class-subobjects obj) ;; access list of functions
(dolist (child-obj it) ;; for each child function
(awhen (funcall (reader child-obj) obj)
(load-all-subobjects it))))))
objs))
(defgeneric view-hyperobject (objs fmt strm
&optional label english-only-function
indent subobjects refvars))
(defmethod view-hyperobject (objs (fmt dataformat) (strm stream)
&optional (label nil) (indent 0)
(english-only-function nil)
(subobjects nil) (refvars nil))
"Display a single or list of hyperobject-class instances and their subobjects"
(when objs
(setq objs (mklist objs))
(let ((nobjs (length objs)))
(fmt-list-start (car objs) fmt strm indent nobjs)
(dolist (obj objs)
(unless (and english-only-function
(multiple-value-bind (eng term) (funcall english-only-function obj)
(and term (not eng))))
(fmt-obj-start obj fmt strm indent)
(fmt-obj-data obj fmt strm (1+ indent) label refvars)
(if subobjects
(awhen (hyperobject-class-subobjects obj) ;; access list of functions
(dolist (child-obj it) ;; for each child function
(awhen (funcall (reader child-obj) obj) ;; access set of child objects
(view-hyperobject it fmt strm label
(1+ indent) english-only-function
subobjects refvars)))))
(fmt-obj-end obj fmt strm indent)))
(fmt-list-end (car objs) fmt strm indent nobjs))
t))
(defun view (objs &key (os *standard-output*) (format :text)
(label nil) (english-only-function nil)
(subobjects nil) (file-wrapper t) (refvars nil))
"EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
(let ((fmt (make-format-instance format)))
(if file-wrapper
(fmt-file-start fmt os))
(when objs
(view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
(if file-wrapper
(fmt-file-end fmt os)))
objs)