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.2 2002/11/25 07:45:35 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 3) (safety 1) (compilation-speed 0) (debug 3))))
  20
  21 (defparameter *default-textformat* nil)
  22 (defparameter *default-htmlformat* nil)
  23 (defparameter *default-htmlrefformat* nil)
  24 (defparameter *default-xhtmlformat* nil)
  25 (defparameter *default-xhtmlrefformat* nil)
  26 (defparameter *default-xmlformat* nil)
  27 (defparameter *default-xmlrefformat* nil)
  28 (defparameter *default-ie-xmlrefformat* nil)
  29 (defparameter *default-nullformat* nil)
  30 (defparameter *default-init-format?* nil)
  31
  32 (defun make-format-instance (fmt)
  33   (unless *default-init-format?*
  34     (setq *default-textformat* (make-instance 'textformat))
  35     (setq *default-htmlformat* (make-instance 'htmlformat))
  36     (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
  37     (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
  38     (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
  39     (setq *default-xmlformat* (make-instance 'xmlformat))
  40     (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
  41     (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
  42     (setq *default-nullformat* (make-instance 'nullformat))
  43     (setq *default-init-format?* t))
  44
  45   (case fmt
  46       (:text *default-textformat*)
  47       (:html *default-htmlformat*)
  48       (:htmlref *default-htmlrefformat*)
  49       (:xhtml  *default-xhtmlformat*)
  50       (:xhtmlref *default-xhtmlrefformat*)
  51       (:xml  *default-xmlformat*)
  52       (:xmlref *default-xmlrefformat*)
  53       (:ie-xmlref *default-ie-xmlrefformat*)
  54       (:null *default-nullformat*)
  55       (otherwise *default-textformat*)))
  56
  57 ;;;; Output format classes for print hyperobject-classes
  58
  59 (defclass dataformat ()
  60   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
  61    (file-end-str :type string :initarg :file-end-str :reader file-end-str)
  62    (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
  63    (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
  64    (list-start-indent :initarg :list-start-indent :reader list-start-indent)
  65    (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
  66    (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
  67    (list-end-indent :initarg :list-end-indent :reader list-end-indent)
  68    (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
  69    (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
  70    (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
  71    (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
  72    (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
  73    (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
  74    (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
  75    (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
  76    (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
  77    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
  78    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
  79    (link-ref :initarg :link-ref :reader link-ref))
  80   (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
  81                      :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
  82                      :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
  83                      :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
  84                      :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
  85                      :obj-data-value-func nil :link-ref nil)
  86   (:documentation "Parent for all dataformat objects"))
  87
  88 (defclass binaryformat (dataformat)
  89   ())
  90
  91 (defclass nullformat (dataformat)
  92   ())
  93
  94 (defun text-list-start-value-func (obj nitems)
  95   (values (hyperobject-class-title obj) nitems))
  96
  97 (defclass textformat (dataformat)
  98   ()
  99   (:default-initargs :list-start-fmtstr "~a~P:~%"
 100     :list-start-value-func #'text-list-start-value-func
 101     :list-start-indent t
 102     :obj-data-indent t
 103     :obj-data-fmtstr #'hyperobject-class-fmtstr-text
 104     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
 105     :obj-data-end-fmtstr "~%"
 106     :obj-data-value-func #'hyperobject-class-value-func))
 107
 108
 109 (defun class-name-of (obj)
 110   (string-downcase (class-name (class-of obj))))
 111
 112 (defun htmlformat-list-start-value-func (x nitems)
 113   (values (hyperobject-class-title x) nitems (class-name-of x)))
 114
 115 (defclass htmlformat (textformat)
 116   ()
 117   (:default-initargs :file-start-str "<html><body>~%"
 118     :file-end-str "</body><html>~%"
 119     :list-start-indent t
 120     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 121     :list-start-value-func #'htmlformat-list-start-value-func
 122     :list-end-fmtstr "</ul></div>~%"
 123     :list-end-indent t
 124     :list-end-value-func #'identity
 125     :obj-start-indent t
 126     :obj-start-fmtstr "<li>"
 127     :obj-start-value-func #'identity
 128     :obj-end-indent  t
 129     :obj-end-fmtstr  "</li>~%"
 130     :obj-end-value-func #'identity
 131     :obj-data-indent t
 132     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 133     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 134     :obj-data-value-func #'hyperobject-class-value-func))
 135
 136 (defclass xhtmlformat (textformat)
 137   ()
 138   (:default-initargs :file-start-str "<html><body>~%"
 139     :file-end-str "</body><html>~%"
 140     :list-start-indent t
 141     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 142     :list-start-value-func #'htmlformat-list-start-value-func
 143     :list-end-fmtstr "</ul></div>~%"
 144     :list-end-indent t
 145     :list-end-value-func #'identity
 146     :obj-start-indent t
 147     :obj-start-fmtstr "<li>"
 148     :obj-start-value-func #'identity
 149     :obj-end-indent  t
 150     :obj-end-fmtstr  "</li>~%"
 151     :obj-end-value-func #'identity
 152     :obj-data-indent t
 153     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 154     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 155     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 156
 157
 158 (defun xmlformat-list-end-value-func (x)
 159   (format nil "~alist" (class-name-of x)))
 160
 161 (defun xmlformat-list-start-value-func (x nitems)
 162   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
 163
 164 (defclass xmlformat (textformat)
 165   ()
 166   (:default-initargs :file-start-str "" ; (std-xml-header)
 167     :list-start-indent  t
 168     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 169     :list-start-value-func #'xmlformat-list-start-value-func
 170     :list-end-indent  t
 171     :list-end-fmtstr "</~a>~%"
 172     :list-end-value-func #'xmlformat-list-end-value-func
 173     :obj-start-fmtstr "<~a>"
 174     :obj-start-value-func #'class-name-of
 175     :obj-start-indent t
 176     :obj-end-fmtstr "</~a>~%"
 177     :obj-end-value-func #'class-name-of
 178     :obj-end-indent nil
 179     :obj-data-indent nil
 180     :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
 181     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
 182     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 183
 184 (defclass link-ref ()
 185   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 186    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 187    (page-name :type string :initarg :page-name :accessor page-name)
 188    (href-head :type string :initarg :href-head :accessor href-head)
 189    (href-end :type string :initarg :href-end :accessor href-end)
 190    (ampersand :type string :initarg :ampersand :accessor ampersand))
 191   (:default-initargs :fmtstr nil
 192     :fmtstr-labels nil
 193     :page-name "disp-func1"
 194     :href-head nil :href-end nil :ampersand nil)
 195   (:documentation "Formatting for a linked reference"))
 196
 197 (defclass html-link-ref (link-ref)
 198   ()
 199   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 200     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 201     :href-head "a href="
 202     :href-end "a"
 203     :ampersand "&"))
 204
 205 (defclass xhtml-link-ref (link-ref)
 206   ()
 207   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 208     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 209     :href-head "a href="
 210     :href-end "a"
 211     :ampersand "&amp;"))
 212
 213 (defclass xml-link-ref (link-ref)
 214   ()
 215   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
 216                      :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 217                      :href-head "xmllink xlink:type=\"simple\" xlink:href="
 218                      :href-end "xmllink"
 219                      :ampersand "&amp;")
 220   (:documentation "Mozilla's and W3's idea of a link with XML"))
 221
 222 (defclass ie-xml-link-ref (xml-link-ref)
 223   ()
 224   (:default-initargs :href-head "html:a href="
 225                      :href-end "html:a" )
 226   (:documentation "Internet Explorer's idea of a link with XML"))
 227
 228
 229 (defclass htmlrefformat (htmlformat)
 230   ()
 231   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 232
 233 (defclass xhtmlrefformat (xhtmlformat)
 234   ()
 235   (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
 236
 237 (defclass xmlrefformat (xmlformat)
 238   ()
 239   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 240
 241 (defclass ie-xmlrefformat (xmlformat)
 242   ()
 243   (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
 244
 245
 246 ;;; File Start and Ends
 247
 248 (defgeneric fmt-file-start (fmt s))
 249 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 250
 251 (defmethod fmt-file-start ((fmt textformat) (s stream))
 252   (aif (file-start-str fmt)
 253       (format s it)))
 254
 255 (defgeneric fmt-file-end (fmt s))
 256 (defmethod fmt-file-end ((fmt textformat) (s stream))
 257   (aif (file-end-str fmt)
 258           (format s it)))
 259
 260 ;;; List Start and Ends
 261
 262 (defgeneric fmt-list-start (obj fmt s &optional indent num-items))
 263 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 264   (if (list-start-indent fmt)
 265       (indent-spaces indent s))
 266   (aif (list-start-fmtstr fmt)
 267           (apply #'format s it
 268                  (multiple-value-list
 269                   (funcall (list-start-value-func fmt) x num-items)))))
 270
 271 (defgeneric fmt-list-end (obj fmt s &optional indent num-items))
 272 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 273   (declare (ignore num-items))
 274   (if (list-end-indent fmt)
 275       (indent-spaces indent s))
 276   (aif (list-end-fmtstr fmt)
 277           (apply #'format s it
 278                  (multiple-value-list
 279                   (funcall (list-end-value-func fmt) x)))))
 280
 281 ;;; Object Start and Ends
 282
 283 (defgeneric fmt-obj-start (obj fmt s &optional indent))
 284 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 285   (if (obj-start-indent fmt)
 286       (indent-spaces indent s))
 287   (aif (obj-start-fmtstr fmt)
 288           (apply #'format s it
 289                  (multiple-value-list
 290                   (funcall (obj-start-value-func fmt) x)))))
 291
 292 (defgeneric fmt-obj-end (obj fmt s &optional indent))
 293 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 294   (if (obj-end-indent fmt)
 295       (indent-spaces indent s))
 296   (aif (obj-end-fmtstr fmt)
 297           (apply #'format s it
 298                  (multiple-value-list
 299                   (funcall (obj-end-value-func fmt) x)))))
 300
 301 ;;; Object Data
 302
 303 (defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
 304 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 305   (declare (ignore obj fieldname))
 306   (format nil "~a\"~a?func=~a~akey=~a~a\""
 307           (href-head ref) (make-url (page-name ref)) fieldfunc
 308           (ampersand ref) fieldvalue
 309           (if refvars
 310               (let ((varstr ""))
 311                 (dolist (var refvars)
 312                   (string-append varstr (format nil "~a~a=~a"
 313                                                 (ampersand ref) (car var) (cadr var))))
 314                 varstr)
 315             "")))
 316
 317 (defgeneric make-link-end (obj ref fieldname))
 318 (defmethod make-link-end (obj (ref link-ref) fieldname)
 319   (declare (ignore obj fieldname))
 320   (format nil "~a" (href-end ref))
 321   )
 322
 323 (defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
 324 (defmethod fmt-obj-data (x (fmt textformat) s
 325                          &optional (indent 0) (label nil) (refvars nil))
 326   (if (obj-data-indent fmt)
 327       (indent-spaces indent s))
 328   (if (link-ref fmt)
 329       (fmt-obj-data-with-ref x fmt s label refvars)
 330     (fmt-obj-data-plain x fmt s label))
 331   (aif (obj-data-end-fmtstr fmt)
 332        (format s it)))
 333
 334 (defgeneric fmt-obj-data-plain (obj fmt s label))
 335 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 336   (if label
 337       (apply #'format s
 338              (funcall (obj-data-fmtstr-labels fmt) x)
 339              (multiple-value-list
 340               (funcall (funcall (obj-data-value-func fmt) x) x)))
 341     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 342            (multiple-value-list
 343             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 344
 345 (defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
 346 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 347   (let ((refstr (make-ref-data-str x fmt label))
 348         (refvalues nil)
 349         (field-values
 350          (multiple-value-list
 351           (funcall (funcall (obj-data-value-func fmt) x) x))))
 352
 353     ;; make list of reference link fields for printing to refstr template
 354     (dolist (ref (hyperobject-class-references x))
 355       (let ((link-start
 356              (make-link-start x (link-ref fmt) (name ref) (lookup ref)
 357                               (nth (position (name ref)
 358                                              (hyperobject-class-fields x)
 359                                              :key #'(lambda (x)
 360                                                       (slot-definition-name x)))
 361                                    field-values)
 362                               (append (link-parameters ref) refvars)))
 363             (link-end (make-link-end x (link-ref fmt) (name ref))))
 364         (push link-start refvalues)
 365         (push link-end refvalues)))
 366     (setq refvalues (nreverse refvalues))
 367
 368     (apply #'format s refstr refvalues)))
 369
 370 (defgeneric obj-data (obj))
 371 (defmethod obj-data (x)
 372   "Returns the objects data as a string. Used by common-graphics outline function"
 373   (let ((fmt (make-format-instance :text)))
 374     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 375            (multiple-value-list
 376             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 377
 378 (defgeneric make-ref-data-str (obj fmt &optional label))
 379 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 380   "Return fmt string for that contains ~a slots for reference link start and end"
 381   (unless (link-ref fmt)
 382     (error "fmt does not contain a link-ref"))
 383   (let ((refstr
 384          (if label
 385              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 386                     (multiple-value-list
 387                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 388            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 389                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 390     refstr))
 391
 392 ;;; Display method for objects
 393
 394
 395 (defgeneric load-all-subobjects (objs))
 396 (defmethod load-all-subobjects (objs)
 397   "Load all subobjects if they have not already been loaded."
 398   (when objs
 399     (let ((objlist (mklist objs)))
 400       (dolist (obj objlist)
 401         (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 402           (dolist (child-obj it)   ;; for each child function
 403             (awhen (funcall (reader child-obj) obj)
 404               (load-all-subobjects it))))))
 405     objs))
 406
 407 (defgeneric view-hyperobject (objs fmt strm
 408                                   &optional label english-only-function
 409                                   indent subobjects refvars))
 410
 411 (defmethod view-hyperobject (objs (fmt dataformat) (strm stream)
 412                                  &optional (label nil) (indent 0)
 413                                  (english-only-function nil)
 414                                  (subobjects nil) (refvars nil))
 415 "Display a single or list of hyperobject-class instances and their subobjects"
 416   (when objs
 417     (setq objs (mklist objs))
 418     (let ((nobjs (length objs)))
 419       (fmt-list-start (car objs) fmt strm indent nobjs)
 420       (dolist (obj objs)
 421         (unless (and english-only-function
 422                   (multiple-value-bind (eng term) (funcall english-only-function obj)
 423                     (and term (not eng))))
 424           (fmt-obj-start obj fmt strm indent)
 425           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 426           (if subobjects
 427               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 428                         (dolist (child-obj it)   ;; for each child function
 429                           (awhen (funcall (reader child-obj) obj) ;; access set of child objects
 430                                     (view-hyperobject it fmt strm label
 431                                                      (1+ indent) english-only-function
 432                                                      subobjects refvars)))))
 433           (fmt-obj-end obj fmt strm indent)))
 434       (fmt-list-end (car objs) fmt strm indent nobjs))
 435     t))
 436
 437
 438 (defun view (objs &key (os *standard-output*) (format :text)
 439                       (label nil) (english-only-function nil)
 440                       (subobjects nil) (file-wrapper t) (refvars nil))
 441   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
 442   (let ((fmt (make-format-instance format)))
 443     (if file-wrapper
 444         (fmt-file-start fmt os))
 445     (when objs
 446       (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
 447     (if file-wrapper
 448         (fmt-file-end fmt os)))
 449   objs)
 450