hyperobject.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          hyperobject.lisp
   6 ;;;; Purpose:       Hyper Object Metaclass
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; This metaclass as functions to classes to allow display
  11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
  12 ;;;; capability and sub-objects.
  13 ;;;;
  14 ;;;; $Id: hyperobject.lisp,v 1.14 2002/11/25 04:47:23 kevin Exp $
  15 ;;;;
  16 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
  17 ;;;;
  18 ;;;; *************************************************************************
  19
  20 (in-package :hyperobject)
  21
  22 (eval-when (:compile-toplevel :execute)
  23   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
  24
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (shadowing-import
  27    #+allegro
  28    `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance
  29      mop::standard-direct-slot-definition mop::standard-effective-slot-definition
  30      mop:direct-slot-definition-class mop:compute-effective-slot-definition
  31      excl::compute-effective-slot-definition-initargs)
  32    #+lispworks
  33    `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance
  34      clos::standard-direct-slot-definition clos::standard-effective-slot-definition
  35      clos:direct-slot-definition-class clos:compute-effective-slot-definition
  36      clos::compute-effective-slot-definition-initargs)
  37    #+sbcl
  38    `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
  39      sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
  40      sb-pcl::standard-direct-slot-definition
  41      sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
  42      sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
  43      sb-pcl::compute-effective-slot-definition-initargs)
  44    #+cmu
  45    `(pcl:class-of  pcl:class-name pcl:class-slots pcl::standard-class
  46      pcl::slot-definition-name pcl:finalize-inheritance
  47      pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
  48      pcl::validate-superclass pcl:direct-slot-definition-class
  49      pcl:compute-effective-slot-definition
  50      pcl::compute-effective-slot-definition-initargs)
  51
  52    :hyperobject))
  53
  54
  55 ;; Slot definitions
  56
  57
  58 (defclass hyperobject-dsd (standard-direct-slot-definition)
  59   ((ho-type :initarg :ho-type :initform nil)
  60    (print-formatter :initarg :print-formatter :initform nil)
  61    (subobject :initarg :subobject :initform nil)
  62    (reference :initarg :reference :initform nil)
  63    (description :initarg :description :initform nil)
  64    ))
  65
  66 (defclass hyperobject-esd (standard-effective-slot-definition)
  67   ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type)
  68    (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter)
  69    (subobject :initarg :subobject :initform nil :accessor esd-subobject)
  70    (reference :initarg :reference :initform nil :accessor esd-reference)
  71    (description :initarg :description :initform nil :accessor esd-description)
  72   ))
  73
  74 ;; Main class
  75
  76 (defclass hyperobject-class (standard-class)
  77   ( ;; slots initialized in defclass
  78    (title :initarg :title :type string :initform nil
  79           :documentation "Print Title for class")
  80    (print-slots :initarg :print-slots :type list :initform nil
  81                 :documentation "List of slots to print")
  82    (description :initarg :description :initform nil
  83                 :documentation "Class description")
  84
  85    ;;; The remainder of these fields are calculated one time
  86    ;;; in finalize-inheritence.
  87
  88    (subobjects :initform nil :documentation
  89                "List of fields that contain a list of subobjects objects.")
  90    (references :type list :initform nil :documentation
  91                "List of fields that have references")
  92
  93    (value-func :initform nil :type function)
  94    (xmlvalue-func :initform nil :type function)
  95    (fmtstr-text :initform nil :type string)
  96    (fmtstr-html :initform nil :type string)
  97    (fmtstr-xml :initform nil :type string)
  98    (fmtstr-text-labels :initform nil :type string)
  99    (fmtstr-html-labels :initform nil :type string)
 100    (fmtstr-xml-labels :initform nil :type string)
 101    (fmtstr-html-ref :initform nil :type string)
 102    (fmtstr-xml-ref :initform nil :type string)
 103    (fmtstr-html-ref-labels :initform nil :type string)
 104    (fmtstr-xml-ref-labels :initform nil :type string)
 105    )
 106   (:documentation "Metaclass for Markup Language classes."))
 107
 108 (defclass subobject ()
 109   ((name :type symbol :initform nil :initarg :name :reader name)
 110    (reader :type function :initform nil :initarg :reader :reader reader)))
 111
 112 (defmethod print-object ((obj subobject) (s stream))
 113   (print-unreadable-object (obj s :type t :identity t)
 114     (format s "~S" (name obj))))
 115
 116 (defclass reference ()
 117   ((name :type symbol :initform nil :initarg :name :reader name)
 118    (lookup :type function :initform nil :initarg :lookup :reader lookup)
 119    (link-parameters :type list :initform nil :initarg :link-parameters
 120                     :reader link-parameters)))
 121
 122 (defmethod print-object ((obj reference) (s stream))
 123   (print-unreadable-object (obj s :type t :identity t)
 124     (format s "~S" (name obj))))
 125
 126 #+(or cmu scl sbcl)
 127 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
 128   t)
 129
 130 (defmethod finalize-inheritance :after ((cl hyperobject-class))
 131   (init-hyperobject-class cl))
 132
 133 ;; Slot definitions
 134 (defmethod direct-slot-definition-class ((cl hyperobject-class)
 135                                          #+allegro &rest
 136                                                    iargs)
 137   (find-class 'hyperobject-dsd))
 138
 139 (defmacro define-class-option (slot-name &optional required)
 140   #+lispworks
 141   `(defmethod clos:process-a-class-option ((class hyperobject-class)
 142                                            (name (eql ,slot-name))
 143                                            value)
 144      (when (and ,required (null value))
 145        (error "hyperobject class slot ~A must have a value" name))
 146      (if (null (cdr value))
 147          (list name (car value))
 148        (list name `',value)))
 149   #+(or allegro sbcl cmu scl)
 150   (declare (ignore slot-name required))
 151   )
 152
 153 (defmacro define-slot-option (slot-name)
 154   #+lispworks
 155   `(defmethod clos:process-a-slot-option ((class hyperobject-class)
 156                                           (option (eql ,slot-name))
 157                                           value
 158                                           already-processed-other-options
 159                                           slot)
 160     (if (null (cdr value))
 161         (list option (car value))
 162         (list option `',value)))
 163   #-lispworks
 164   (declare (ignore slot-name))
 165   )
 166
 167 (define-class-option :title)
 168 (define-class-option :print-slots)
 169 (define-class-option :description)
 170
 171 (define-slot-option :ho-type)
 172 (define-slot-option :print-formatter)
 173 (define-slot-option :subobject)
 174 (define-slot-option :reference)
 175 (define-slot-option :description)
 176
 177
 178
 179 (defmethod compute-effective-slot-definition :around
 180     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
 181   #+allergo (declare (ignore name))
 182   (let* ((dsd (car dsds))
 183          (ho-type (slot-value dsd 'type)))
 184     (setf (slot-value dsd 'ho-type) ho-type)
 185     (setf (slot-value dsd 'type) (convert-ho-type ho-type))
 186     (let ((ia (compute-effective-slot-definition-initargs
 187                cl #+lispworks name dsds)))
 188       (apply
 189        #'make-instance 'hyperobject-esd
 190        :ho-type ho-type
 191        :print-formatter (slot-value dsd 'print-formatter)
 192        :subobject (slot-value dsd 'subobject)
 193        :reference (slot-value dsd 'reference)
 194        :description (slot-value dsd 'description)
 195        ia)))
 196   )
 197
 198 (defun convert-ho-type (ho-type)
 199   (check-type ho-type symbol)
 200   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 201     (:string
 202      'string)
 203     (:fixnum
 204      'fixnum)
 205     (:boolean
 206      'boolean)
 207     (:integer
 208      'integer)
 209     (:cdata
 210      'string)
 211     (:float
 212      'float)
 213     (otherwise
 214      ho-type)))
 215
 216 ;;;; Class initialization function
 217
 218 (defun find-slot-by-name (cl name)
 219   (find name (class-slots cl) :key #'slot-definition-name))
 220
 221
 222 (defun process-subobjects (cl)
 223   "Process class subobjects slot"
 224   (setf (slot-value cl 'subobjects)
 225     (let ((subobjects '()))
 226       (dolist (slot (class-slots cl))
 227         (when (slot-value slot 'subobject)
 228           (push (make-instance 'subobject :name (slot-definition-name slot)
 229                                :reader (if (eq t (esd-subobject slot))
 230                                            (slot-definition-name slot)
 231                                          (esd-subobject slot)))
 232                 subobjects)))
 233       subobjects)))
 234
 235 (defun process-documentation (cl)
 236   "Calculate class documentation slot"
 237   (awhen (slot-value cl 'title)
 238          (setf (slot-value cl 'title) (car it)))
 239   (awhen (slot-value cl 'description)
 240          (setf (slot-value cl 'description) (car it)))
 241
 242   (let ((*print-circle* nil))
 243     (setf (documentation (class-name cl) 'class)
 244       (format nil "Hyperobject~A~A~A~A"
 245               (aif (slot-value cl 'title)
 246                    (format nil ": ~A" it ""))
 247               (aif (slot-value cl 'description)
 248                    (format nil "~%Class description: ~A" it) "")
 249               (aif (slot-value cl 'subobjects)
 250                    (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
 251               (aif (slot-value cl 'print-slots)
 252                    (format nil "~%Print-slots:~{ ~A~}" it) "")
 253               ))))
 254
 255 (defun process-views (cl)
 256   "Calculate all view slots for a hyperobject class"
 257   (let ((fmtstr-text "")
 258         (fmtstr-html "")
 259         (fmtstr-xml "")
 260         (fmtstr-text-labels "")
 261         (fmtstr-html-labels "")
 262         (fmtstr-xml-labels "")
 263         (fmtstr-html-ref "")
 264         (fmtstr-xml-ref "")
 265         (fmtstr-html-ref-labels "")
 266         (fmtstr-xml-ref-labels "")
 267         (first-field t)
 268         (value-func '())
 269         (xmlvalue-func '())
 270         (classname (class-name cl))
 271         (package (symbol-package (class-name cl)))
 272         (references nil))
 273     (declare (ignore classname))
 274     (dolist (slot-name (slot-value cl 'print-slots))
 275       (let ((slot (find-slot-by-name cl slot-name)))
 276         (unless slot
 277           (error "Slot ~A is not found in class ~S" slot-name cl))
 278         (let ((name (slot-definition-name slot))
 279               (namestr (symbol-name (slot-definition-name slot)))
 280               (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
 281               (type (slot-value slot 'ho-type))
 282               (print-formatter (slot-value slot 'print-formatter))
 283               (value-fmt "~a")
 284               (plain-value-func nil)
 285               html-str xml-str html-label-str xml-label-str)
 286
 287           (when (or (eql type :integer) (eql type :fixnum))
 288             (setq value-fmt "~d"))
 289
 290           (when (eql type :boolean)
 291             (setq value-fmt "~a"))
 292
 293           (if first-field
 294               (setq first-field nil)
 295               (progn
 296                 (string-append fmtstr-text " ")
 297                 (string-append fmtstr-html " ")
 298                 (string-append fmtstr-xml " ")
 299                 (string-append fmtstr-text-labels " ")
 300                 (string-append fmtstr-html-labels " ")
 301                 (string-append fmtstr-xml-labels " ")
 302                 (string-append fmtstr-html-ref " ")
 303                 (string-append fmtstr-xml-ref " ")
 304                 (string-append fmtstr-html-ref-labels " ")
 305                 (string-append fmtstr-xml-ref-labels " ")))
 306
 307           (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
 308           (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 309           (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
 310           (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 311
 312           (string-append fmtstr-text value-fmt)
 313           (string-append fmtstr-html html-str)
 314           (string-append fmtstr-xml xml-str)
 315           (string-append fmtstr-text-labels namestr-lower " " value-fmt)
 316           (string-append fmtstr-html-labels html-label-str)
 317           (string-append fmtstr-xml-labels xml-label-str)
 318
 319           (if (esd-reference slot)
 320               (progn
 321                 (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
 322                 (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
 323                 (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 324                 (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
 325                 (push (make-instance 'reference :name name :lookup (esd-reference slot))
 326                       references))
 327               (progn
 328                 (string-append fmtstr-html-ref html-str)
 329                 (string-append fmtstr-xml-ref xml-str)
 330                 (string-append fmtstr-html-ref-labels html-label-str)
 331                 (string-append fmtstr-xml-ref-labels xml-label-str)))
 332
 333           (if print-formatter
 334               (setq plain-value-func
 335                     (list `(,print-formatter (,(intern namestr package) x))))
 336               (setq plain-value-func
 337                     (list `(,(intern namestr package) x))))
 338           (setq value-func (append value-func plain-value-func))
 339
 340           (if (eql type :cdata)
 341               (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
 342               (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
 343           )))
 344
 345     (setf (slot-value cl 'references) references)
 346
 347     (if value-func
 348         (setq value-func `(lambda (x) (values ,@value-func)))
 349         (setq value-func `(lambda () (values))))
 350     (setq value-func (compile nil (eval value-func)))
 351
 352     (if xmlvalue-func
 353         (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 354         (setq xmlvalue-func `(lambda () (values))))
 355     (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
 356
 357     (setf (slot-value cl 'fmtstr-text) fmtstr-text)
 358     (setf (slot-value cl 'fmtstr-html) fmtstr-html)
 359     (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
 360     (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
 361     (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
 362     (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
 363     (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
 364     (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
 365     (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
 366     (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
 367     (setf (slot-value cl 'value-func) value-func)
 368     (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
 369   (values))
 370
 371 (defun init-hyperobject-class (cl)
 372   "Initialize a hyperobject class. Calculates all class slots"
 373   (process-subobjects cl)
 374   (process-views cl)
 375   (process-documentation cl))
 376
 377 (defun hyperobject-class-fmtstr-text (obj)
 378   (slot-value (class-of obj) 'fmtstr-text))
 379
 380 (defun hyperobject-class-fmtstr-html (obj)
 381   (slot-value (class-of obj) 'fmtstr-html))
 382
 383 (defun hyperobject-class-fmtstr-xml (obj)
 384   (slot-value (class-of obj) 'fmtstr-xml))
 385
 386 (defun hyperobject-class-fmtstr-text-labels (obj)
 387   (slot-value (class-of obj) 'fmtstr-text-labels))
 388
 389 (defun hyperobject-class-fmtstr-html-labels (obj)
 390   (slot-value (class-of obj) 'fmtstr-html-labels))
 391
 392 (defun hyperobject-class-fmtstr-xml-labels (obj)
 393   (slot-value (class-of obj) 'fmtstr-xml-labels))
 394
 395 (defun hyperobject-class-value-func (obj)
 396   (slot-value (class-of obj) 'value-func))
 397
 398 (defun hyperobject-class-xmlvalue-func (obj)
 399   (slot-value (class-of obj) 'xmlvalue-func))
 400
 401 (eval-when (:compile-toplevel :load-toplevel :execute)
 402 (defun hyperobject-class-title (obj)
 403   (awhen (slot-value (class-of obj) 'title)
 404             (if (consp it)
 405                 (car it)
 406               it))))
 407
 408 (defun hyperobject-class-subobjects (obj)
 409   (slot-value (class-of obj) 'subobjects))
 410
 411 (defun hyperobject-class-references (obj)
 412   (slot-value (class-of obj) 'references))
 413
 414 (defun hyperobject-class-fields (obj)
 415   (class-slots (class-of obj)))
 416
 417 (defun hyperobject-class-fmtstr-html-ref (obj)
 418   (slot-value (class-of obj) 'fmtstr-html-ref))
 419
 420 (defun hyperobject-class-fmtstr-xml-ref (obj)
 421   (slot-value (class-of obj) 'fmtstr-xml-ref))
 422
 423 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 424   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 425
 426 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 427   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 428
 429 ;;;; Generic Print functions
 430
 431 (defparameter *default-textformat* nil)
 432 (defparameter *default-htmlformat* nil)
 433 (defparameter *default-htmlrefformat* nil)
 434 (defparameter *default-xhtmlformat* nil)
 435 (defparameter *default-xhtmlrefformat* nil)
 436 (defparameter *default-xmlformat* nil)
 437 (defparameter *default-xmlrefformat* nil)
 438 (defparameter *default-ie-xmlrefformat* nil)
 439 (defparameter *default-nullformat* nil)
 440 (defparameter *default-init-format?* nil)
 441
 442 (defun make-format-instance (fmt)
 443   (unless *default-init-format?*
 444     (setq *default-textformat* (make-instance 'textformat))
 445     (setq *default-htmlformat* (make-instance 'htmlformat))
 446     (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
 447     (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
 448     (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
 449     (setq *default-xmlformat* (make-instance 'xmlformat))
 450     (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
 451     (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
 452     (setq *default-nullformat* (make-instance 'nullformat))
 453     (setq *default-init-format?* t))
 454
 455   (case fmt
 456       (:text *default-textformat*)
 457       (:html *default-htmlformat*)
 458       (:htmlref *default-htmlrefformat*)
 459       (:xhtml  *default-xhtmlformat*)
 460       (:xhtmlref *default-xhtmlrefformat*)
 461       (:xml  *default-xmlformat*)
 462       (:xmlref *default-xmlrefformat*)
 463       (:ie-xmlref *default-ie-xmlrefformat*)
 464       (:null *default-nullformat*)
 465       (otherwise *default-textformat*)))
 466
 467 ;;;; Output format classes for print hyperobject-classes
 468
 469 (defclass dataformat ()
 470   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
 471    (file-end-str :type string :initarg :file-end-str :reader file-end-str)
 472    (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
 473    (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
 474    (list-start-indent :initarg :list-start-indent :reader list-start-indent)
 475    (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
 476    (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
 477    (list-end-indent :initarg :list-end-indent :reader list-end-indent)
 478    (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
 479    (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
 480    (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
 481    (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
 482    (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
 483    (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
 484    (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
 485    (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
 486    (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
 487    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
 488    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
 489    (link-ref :initarg :link-ref :reader link-ref))
 490   (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
 491                      :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
 492                      :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
 493                      :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
 494                      :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
 495                      :obj-data-value-func nil :link-ref nil)
 496   (:documentation "Parent for all dataformat objects"))
 497
 498 (defclass binaryformat (dataformat)
 499   ())
 500
 501 (defclass nullformat (dataformat)
 502   ())
 503
 504 (defun text-list-start-value-func (obj nitems)
 505   (values (hyperobject-class-title obj) nitems))
 506
 507 (defclass textformat (dataformat)
 508   ()
 509   (:default-initargs :list-start-fmtstr "~a~P:~%"
 510     :list-start-value-func #'text-list-start-value-func
 511     :list-start-indent t
 512     :obj-data-indent t
 513     :obj-data-fmtstr #'hyperobject-class-fmtstr-text
 514     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
 515     :obj-data-end-fmtstr "~%"
 516     :obj-data-value-func #'hyperobject-class-value-func))
 517
 518
 519 (defun class-name-of (obj)
 520   (string-downcase (class-name (class-of obj))))
 521
 522 (defun htmlformat-list-start-value-func (x nitems)
 523   (values (hyperobject-class-title x) nitems (class-name-of x)))
 524
 525 (defclass htmlformat (textformat)
 526   ()
 527   (:default-initargs :file-start-str "<html><body>~%"
 528     :file-end-str "</body><html>~%"
 529     :list-start-indent t
 530     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 531     :list-start-value-func #'htmlformat-list-start-value-func
 532     :list-end-fmtstr "</ul></div>~%"
 533     :list-end-indent t
 534     :list-end-value-func #'identity
 535     :obj-start-indent t
 536     :obj-start-fmtstr "<li>"
 537     :obj-start-value-func #'identity
 538     :obj-end-indent  t
 539     :obj-end-fmtstr  "</li>~%"
 540     :obj-end-value-func #'identity
 541     :obj-data-indent t
 542     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 543     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 544     :obj-data-value-func #'hyperobject-class-value-func))
 545
 546 (defclass xhtmlformat (textformat)
 547   ()
 548   (:default-initargs :file-start-str "<html><body>~%"
 549     :file-end-str "</body><html>~%"
 550     :list-start-indent t
 551     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 552     :list-start-value-func #'htmlformat-list-start-value-func
 553     :list-end-fmtstr "</ul></div>~%"
 554     :list-end-indent t
 555     :list-end-value-func #'identity
 556     :obj-start-indent t
 557     :obj-start-fmtstr "<li>"
 558     :obj-start-value-func #'identity
 559     :obj-end-indent  t
 560     :obj-end-fmtstr  "</li>~%"
 561     :obj-end-value-func #'identity
 562     :obj-data-indent t
 563     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 564     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 565     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 566
 567
 568 (defun xmlformat-list-end-value-func (x)
 569   (format nil "~alist" (class-name-of x)))
 570
 571 (defun xmlformat-list-start-value-func (x nitems)
 572   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
 573
 574 (defclass xmlformat (textformat)
 575   ()
 576   (:default-initargs :file-start-str "" ; (std-xml-header)
 577     :list-start-indent  t
 578     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 579     :list-start-value-func #'xmlformat-list-start-value-func
 580     :list-end-indent  t
 581     :list-end-fmtstr "</~a>~%"
 582     :list-end-value-func #'xmlformat-list-end-value-func
 583     :obj-start-fmtstr "<~a>"
 584     :obj-start-value-func #'class-name-of
 585     :obj-start-indent t
 586     :obj-end-fmtstr "</~a>~%"
 587     :obj-end-value-func #'class-name-of
 588     :obj-end-indent nil
 589     :obj-data-indent nil
 590     :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
 591     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
 592     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 593
 594 (defclass link-ref ()
 595   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 596    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 597    (page-name :type string :initarg :page-name :accessor page-name)
 598    (href-head :type string :initarg :href-head :accessor href-head)
 599    (href-end :type string :initarg :href-end :accessor href-end)
 600    (ampersand :type string :initarg :ampersand :accessor ampersand))
 601   (:default-initargs :fmtstr nil
 602     :fmtstr-labels nil
 603     :page-name "disp-func1"
 604     :href-head nil :href-end nil :ampersand nil)
 605   (:documentation "Formatting for a linked reference"))
 606
 607 (defclass html-link-ref (link-ref)
 608   ()
 609   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 610     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 611     :href-head "a href="
 612     :href-end "a"
 613     :ampersand "&"))
 614
 615 (defclass xhtml-link-ref (link-ref)
 616   ()
 617   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 618     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 619     :href-head "a href="
 620     :href-end "a"
 621     :ampersand "&amp;"))
 622
 623 (defclass xml-link-ref (link-ref)
 624   ()
 625   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
 626                      :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 627                      :href-head "xmllink xlink:type=\"simple\" xlink:href="
 628                      :href-end "xmllink"
 629                      :ampersand "&amp;")
 630   (:documentation "Mozilla's and W3's idea of a link with XML"))
 631
 632 (defclass ie-xml-link-ref (xml-link-ref)
 633   ()
 634   (:default-initargs :href-head "html:a href="
 635                      :href-end "html:a" )
 636   (:documentation "Internet Explorer's idea of a link with XML"))
 637
 638
 639 (defclass htmlrefformat (htmlformat)
 640   ()
 641   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 642
 643 (defclass xhtmlrefformat (xhtmlformat)
 644   ()
 645   (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
 646
 647 (defclass xmlrefformat (xmlformat)
 648   ()
 649   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 650
 651 (defclass ie-xmlrefformat (xmlformat)
 652   ()
 653   (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
 654
 655
 656 ;;; File Start and Ends
 657
 658 (defgeneric fmt-file-start (fmt s))
 659 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 660
 661 (defmethod fmt-file-start ((fmt textformat) (s stream))
 662   (aif (file-start-str fmt)
 663       (format s it)))
 664
 665 (defgeneric fmt-file-end (fmt s))
 666 (defmethod fmt-file-end ((fmt textformat) (s stream))
 667   (aif (file-end-str fmt)
 668           (format s it)))
 669
 670 ;;; List Start and Ends
 671
 672 (defgeneric fmt-list-start (obj fmt s &optional indent num-items))
 673 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 674   (if (list-start-indent fmt)
 675       (indent-spaces indent s))
 676   (aif (list-start-fmtstr fmt)
 677           (apply #'format s it
 678                  (multiple-value-list
 679                   (funcall (list-start-value-func fmt) x num-items)))))
 680
 681 (defgeneric fmt-list-end (obj fmt s &optional indent num-items))
 682 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 683   (declare (ignore num-items))
 684   (if (list-end-indent fmt)
 685       (indent-spaces indent s))
 686   (aif (list-end-fmtstr fmt)
 687           (apply #'format s it
 688                  (multiple-value-list
 689                   (funcall (list-end-value-func fmt) x)))))
 690
 691 ;;; Object Start and Ends
 692
 693 (defgeneric fmt-obj-start (obj fmt s &optional indent))
 694 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 695   (if (obj-start-indent fmt)
 696       (indent-spaces indent s))
 697   (aif (obj-start-fmtstr fmt)
 698           (apply #'format s it
 699                  (multiple-value-list
 700                   (funcall (obj-start-value-func fmt) x)))))
 701
 702 (defgeneric fmt-obj-end (obj fmt s &optional indent))
 703 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 704   (if (obj-end-indent fmt)
 705       (indent-spaces indent s))
 706   (aif (obj-end-fmtstr fmt)
 707           (apply #'format s it
 708                  (multiple-value-list
 709                   (funcall (obj-end-value-func fmt) x)))))
 710
 711 ;;; Object Data
 712
 713 (defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
 714 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 715   (declare (ignore obj fieldname))
 716   (format nil "~a\"~a?func=~a~akey=~a~a\""
 717           (href-head ref) (make-url (page-name ref)) fieldfunc
 718           (ampersand ref) fieldvalue
 719           (if refvars
 720               (let ((varstr ""))
 721                 (dolist (var refvars)
 722                   (string-append varstr (format nil "~a~a=~a"
 723                                                 (ampersand ref) (car var) (cadr var))))
 724                 varstr)
 725             "")))
 726
 727 (defgeneric make-link-end (obj ref fieldname))
 728 (defmethod make-link-end (obj (ref link-ref) fieldname)
 729   (declare (ignore obj fieldname))
 730   (format nil "~a" (href-end ref))
 731   )
 732
 733 (defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
 734 (defmethod fmt-obj-data (x (fmt textformat) s
 735                          &optional (indent 0) (label nil) (refvars nil))
 736   (if (obj-data-indent fmt)
 737       (indent-spaces indent s))
 738   (if (link-ref fmt)
 739       (fmt-obj-data-with-ref x fmt s label refvars)
 740     (fmt-obj-data-plain x fmt s label))
 741   (aif (obj-data-end-fmtstr fmt)
 742        (format s it)))
 743
 744 (defgeneric fmt-obj-data-plain (obj fmt s label))
 745 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 746   (if label
 747       (apply #'format s
 748              (funcall (obj-data-fmtstr-labels fmt) x)
 749              (multiple-value-list
 750               (funcall (funcall (obj-data-value-func fmt) x) x)))
 751     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 752            (multiple-value-list
 753             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 754
 755 (defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
 756 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 757   (let ((refstr (make-ref-data-str x fmt label))
 758         (refvalues nil)
 759         (field-values
 760          (multiple-value-list
 761           (funcall (funcall (obj-data-value-func fmt) x) x))))
 762
 763     ;; make list of reference link fields for printing to refstr template
 764     (dolist (ref (hyperobject-class-references x))
 765       (let ((link-start
 766              (make-link-start x (link-ref fmt) (name ref) (lookup ref)
 767                               (nth (position (name ref)
 768                                              (hyperobject-class-fields x)
 769                                              :key #'(lambda (x)
 770                                                       (slot-definition-name x)))
 771                                    field-values)
 772                               (append (link-parameters ref) refvars)))
 773             (link-end (make-link-end x (link-ref fmt) (name ref))))
 774         (push link-start refvalues)
 775         (push link-end refvalues)))
 776     (setq refvalues (nreverse refvalues))
 777
 778     (apply #'format s refstr refvalues)))
 779
 780 (defgeneric obj-data (obj))
 781 (defmethod obj-data (x)
 782   "Returns the objects data as a string. Used by common-graphics outline function"
 783   (let ((fmt (make-format-instance :text)))
 784     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 785            (multiple-value-list
 786             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 787
 788 (defgeneric make-ref-data-str (obj fmt &optional label))
 789 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 790   "Return fmt string for that contains ~a slots for reference link start and end"
 791   (unless (link-ref fmt)
 792     (error "fmt does not contain a link-ref"))
 793   (let ((refstr
 794          (if label
 795              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 796                     (multiple-value-list
 797                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 798            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 799                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 800     refstr))
 801
 802 ;;; Display method for objects
 803
 804
 805 (defgeneric load-all-subobjects (objs))
 806 (defmethod load-all-subobjects (objs)
 807   "Load all subobjects if they have not already been loaded."
 808   (when objs
 809     (let ((objlist (mklist objs)))
 810       (dolist (obj objlist)
 811         (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 812           (dolist (child-obj it)   ;; for each child function
 813             (awhen (funcall (reader child-obj) obj)
 814               (load-all-subobjects it))))))
 815     objs))
 816
 817 (defgeneric print-hyperobject-class (objs fmt strm
 818                                   &optional label english-only-function
 819                                   indent subobjects refvars))
 820
 821 (defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream)
 822                                  &optional (label nil) (indent 0)
 823                                  (english-only-function nil)
 824                                  (subobjects nil) (refvars nil))
 825 "Display a single or list of hyperobject-class instances and their subobjects"
 826   (when objs
 827     (setq objs (mklist objs))
 828     (let ((nobjs (length objs)))
 829       (fmt-list-start (car objs) fmt strm indent nobjs)
 830       (dolist (obj objs)
 831         (unless (and english-only-function
 832                   (multiple-value-bind (eng term) (funcall english-only-function obj)
 833                     (and term (not eng))))
 834           (fmt-obj-start obj fmt strm indent)
 835           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 836           (if subobjects
 837               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 838                         (dolist (child-obj it)   ;; for each child function
 839                           (awhen (funcall (reader child-obj) obj) ;; access set of child objects
 840                                     (print-hyperobject-class it fmt strm label
 841                                                      (1+ indent) english-only-function
 842                                                      subobjects refvars)))))
 843           (fmt-obj-end obj fmt strm indent)))
 844       (fmt-list-end (car objs) fmt strm indent nobjs))
 845     t))
 846
 847
 848
 849 (defun print-hyperobject (objs &key (os *standard-output*) (format :text)
 850                       (label nil) (english-only-function nil)
 851                       (subobjects nil) (file-wrapper t) (refvars nil))
 852   "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class"
 853   (let ((fmt (make-format-instance format)))
 854     (if file-wrapper
 855         (fmt-file-start fmt os))
 856     (when objs
 857       (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars))
 858     (if file-wrapper
 859         (fmt-file-end fmt os)))
 860   objs)
 861