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.32 2003/05/13 23:10:44 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 2) (safety 2) (compilation-speed 0) (debug 2))))
  20
  21
  22 (defclass object-view ()
  23   ((object-class-name :initform nil :initarg :object-class-name
  24                       :accessor object-class-name
  25                  :documentation "Name of class of object to be viewed.")
  26    (object-class :initform nil :initarg :object-class
  27                  :accessor object-class
  28                  :documentation "Class of object to be viewed.")
  29    (slots :initform nil :initarg :slots :accessor slots
  30           :documentation "List of effective slots for object to be viewed.")
  31    (name :initform nil :initarg :name :accessor name
  32          :documentation "Name for this view.")
  33    (category :initform nil :initarg :category :accessor category
  34              :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
  35    (source-code :initform nil :initarg :source-code :accessor source-code
  36                 :documentation "Source code for generating view.")
  37    (country-language :initform :en :initarg :country-language
  38                      :documentation "Country's Language for this view.")
  39    ;;
  40    (file-start-str :type (or string null) :initform nil :initarg :file-start-str
  41                    :accessor file-start-str)
  42    (file-end-str :type (or string null) :initform nil :initarg :file-end-str
  43                  :accessor file-end-str)
  44    (list-start-str-or-func :type (or string function null) :initform nil
  45                            :initarg :list-start-str-or-func
  46                       :accessor list-start-str-or-func)
  47    (list-start-indent :initform nil :initarg :list-start-indent
  48                       :accessor list-start-indent)
  49    (list-end-str-or-func :type (or string function null) :initform nil
  50                          :initarg :list-end-str-or-func
  51                     :accessor list-end-str-or-func)
  52    (list-end-indent :initform nil :initarg :list-end-indent
  53                     :accessor list-end-indent)
  54    (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func
  55                      :accessor obj-start-str-or-func)
  56    (obj-start-indent :initform nil :initarg :obj-start-indent
  57                      :accessor obj-start-indent)
  58    (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func
  59                    :accessor obj-end-str-or-func)
  60    (obj-end-indent :initform nil :initarg :obj-end-indent
  61                    :accessor obj-end-indent)
  62    (obj-data-indent :initform nil :initarg :obj-data-indent
  63                     :accessor obj-data-indent)
  64    (obj-data-fmtstr :type (or string null) :initform nil :initarg :obj-data-fmtstr
  65                     :accessor obj-data-fmtstr)
  66    (obj-data-value-func :type (or function symbol null) :initform nil
  67                         :initarg :obj-data-value-func
  68                         :accessor obj-data-value-func)
  69    (obj-data-end-str :type (or string null) :initform nil
  70                         :initarg :obj-data-end-str
  71                         :accessor obj-data-end-str)
  72    (link-slots :type list :initform nil
  73                :documentation "List of slot names that have hyperlinks"
  74                :accessor link-slots)
  75    (link-page-name :type (or string null) :initform nil :initarg :link-page-name
  76                    :accessor link-page-name)
  77    (link-href-start :type (or string null) :initform nil :initarg :link-href-start
  78                     :accessor link-href-start)
  79    (link-href-end :type (or string null) :initform nil :initarg :link-href-end
  80                   :accessor link-href-end)
  81    (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
  82                    :accessor link-ampersand))
  83   (:default-initargs :link-page-name "disp-func1")
  84   (:documentation "View class for a hyperobject"))
  85
  86
  87 (defun get-category-view (obj category &optional slots)
  88   "Find or make a category view for an object"
  89   (let ((obj-class (class-of obj)))
  90     (if (null category)
  91         (default-view obj-class)
  92         (aif (find category (views obj-class) :key #'category)
  93              it
  94              (let ((view
  95                     (make-instance 'object-view
  96                                    :object-class-name (class-name obj-class)
  97                                    :object-class obj-class
  98                                    :category category
  99                                    :slots slots)))
 100                (push view (views obj-class))
 101                view)))))
 102
 103 ;;;; *************************************************************************
 104 ;;;;  Metaclass Intialization
 105 ;;;; *************************************************************************
 106
 107 (defun finalize-views (cl)
 108   "Finalize all views that are given on a objects initialization"
 109   (unless (default-print-slots cl)
 110     (setf (default-print-slots cl)
 111           (mapcar #'slot-definition-name (class-slots cl))))
 112   (let ((views '()))
 113     (dolist (view-def (views cl))
 114       (push (make-object-view cl view-def) views))
 115     (setf (views cl) (nreverse views)))
 116   (cond
 117     ((default-view cl)
 118      (setf (default-view cl) (make-object-view cl (default-view cl))))
 119     ((car (views cl))
 120      (setf (default-view cl) (make-object-view cl (car (views cl)))))
 121     (t
 122      (setf (default-view cl) (make-object-view cl :default)))))
 123
 124 (defun make-object-view (cl view-def)
 125   "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
 126   (cond
 127     ((typep view-def 'object-view)
 128      view-def)
 129     ((eq view-def :default)
 130      (let* ((name (class-name cl))
 131             (view (make-instance 'object-view :name "automatic"
 132                                  :object-class-name name
 133                                  :object-class cl
 134                                  :category :compact-text)))
 135        view))
 136     ((consp view-def)
 137      (eval `(make-instance ,view-def)))
 138     (t
 139      (error "Invalid parameter to make-object-view: ~S" view-def))))
 140
 141 (defmethod initialize-instance :after ((view object-view)
 142                                        &rest initargs &key &allow-other-keys)
 143   (initialize-view (object-class view) view))
 144
 145 (defun initialize-view (obj-cl view)
 146   "Calculate all view slots for a hyperobject class"
 147   (cond
 148     ((category view)
 149      (initialize-view-by-category obj-cl view))
 150     ((source-code view)
 151      (initialize-view-by-source-code obj-cl view))
 152     (t
 153      (setf (category view) :compact-text)
 154      (initialize-view-by-category obj-cl view))))
 155
 156 (defun initialize-view-by-source-code (obj-cl view)
 157   "Initialize a view based upon a source code"
 158   (let ((source-code (source-code view)))
 159     (error "not implemented")
 160     )
 161   )
 162
 163
 164 (defun initialize-view-by-category (obj-cl view)
 165   "Initialize a view based upon a preset category"
 166   (let ((fmtstr nil)
 167         (first-field t)
 168         (value-func '())
 169         (links '())
 170         (category (category view)))
 171
 172     (unless (in category :compact-text :compact-text-labels
 173                 :html :html-labels :html-link-labels
 174                 :xhtml :xhtml-labels :xhtml-link-labels
 175                 :xml :xml-labels :xml-link :ie-xml-link
 176                 :xml-link-labels :ie-xml-link-labels)
 177       (error "Unknown view category ~A" category))
 178
 179     (unless (slots view)
 180       (setf (slots view) (default-print-slots obj-cl)))
 181     (dolist (slot-name (slots view))
 182       (let ((slot (find-slot-by-name obj-cl slot-name)))
 183         (unless slot
 184           (error "Slot ~A is not found in class ~S" slot-name obj-cl))
 185         (let* ((name (slot-definition-name slot))
 186                (namestr-lower (string-downcase (symbol-name name)))
 187                (xml-namestr (escape-xml-string namestr-lower))
 188                (xml-tag (escape-xml-string namestr-lower))
 189                (type (slot-value slot 'type))
 190                (print-formatter (esd-print-formatter slot)))
 191
 192           (cond
 193             (first-field
 194              (setq fmtstr "")
 195              (setq first-field nil))
 196             (t
 197              (string-append fmtstr " ")))
 198
 199           (let ((value-fmt
 200                  (case type
 201                    ((or :integer :fixnum)
 202                     "~d")
 203                    (:boolean
 204                     "~a")
 205                    (otherwise
 206                     "~a"))))
 207             (case category
 208               (:compact-text
 209                (string-append fmtstr value-fmt))
 210               (:compact-text-labels
 211                (string-append fmtstr namestr-lower " " value-fmt))
 212               ((or :html :xhtml)
 213                (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>")))
 214               (:xml
 215                (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">")))
 216               (:html-labels
 217                (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
 218               (:xhtml-labels
 219                (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
 220               (:xml-labels
 221                (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))
 222               ((or :html-link :xhtml-link)
 223                (push name links)
 224                (if (esd-hyperlink slot)
 225                    (string-append fmtstr "<~~a>" value-fmt "</~~a>")
 226                    (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 227               ((or :xml-link :ie-xml-link)
 228                (push name links)
 229                (if (esd-hyperlink slot)
 230                    (string-append fmtstr "<~~a>" value-fmt "</~~a>")
 231                    (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "</" xml-tag ">"))))
 232               (:html-link-labels
 233                (push name links)
 234                (if (esd-hyperlink slot)
 235                    (string-append fmtstr "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 236                    (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 237               (:xhtml-link-labels
 238                (push name links)
 239                (if (esd-hyperlink slot)
 240                    (string-append fmtstr "<span class=\"label\">" xml-namestr "</span> <~~a>" value-fmt "</~~a>")
 241                    (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
 242               ((or :xml-link-labels :ie-xml-link-labels)
 243                (push name links)
 244                (if (esd-hyperlink slot)
 245                    (string-append fmtstr "<label>" xml-namestr "</label> <~~a>" value-fmt "</~~a>")
 246                    (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))))
 247             ) ;; let value-fmt
 248
 249           (let ((func (if print-formatter
 250                   `(,print-formatter (slot-value x (quote ,name)))
 251                   `(slot-value x (quote ,name)))))
 252             (when (and (in category :xml :xhtml :xml-link :xhtml-link
 253                            :xml-labels :ie-xml-labels
 254                            :xhtml-link-labels :xml-link-labels :ie-xml-link
 255                            :ie-xml-link-labels)
 256                        (or print-formatter
 257                            (lisp-type-is-a-string type)))
 258               (setq func `(kmrcl:xml-cdata ,func)))
 259             (push func value-func))
 260           )))
 261
 262     (when value-func
 263       (setq value-func
 264             (compile nil (eval `(lambda (x) (values ,@(nreverse value-func)))))))
 265
 266     (setf (obj-data-fmtstr view) fmtstr)
 267     (setf (obj-data-value-func view) value-func)
 268     (setf (link-slots view) (nreverse links))
 269
 270     (case category
 271       ((or :compact-text :compact-text-labels)
 272        (initialize-text-view view))
 273       ((or :html :xhtml :html-labels :xhtml-labels)
 274        (initialize-html-view view))
 275       ((or :xml :xml-labels)
 276        (initialize-xml-view view))
 277       ((or :html-link :html-link-labels)
 278        (initialize-html-view view)
 279        (setf (link-href-start view) "a href=")
 280        (setf (link-href-end view) "a")
 281        (setf (link-ampersand view) "&"))
 282       ((or :xhtml-link :xhtml-link-labels)
 283        (initialize-html-view view)
 284        (setf (link-href-start view) "a href=")
 285        (setf (link-href-end view) "a")
 286        (setf (link-ampersand view) "&amp;"))
 287       ((or :xml-link :xml-link-labels)
 288        (initialize-xml-view view)
 289        (setf (link-href-start view)
 290              "xmllink xlink:type=\"simple\" xlink:href=")
 291        (setf (link-href-end view) "xmllink")
 292        (setf (link-ampersand view) "&amp;"))
 293       ((or :ie-xml-link :ie-xml-link-labels)
 294        (initialize-xml-view view)
 295        (setf (link-href-start view) "html:a href=")
 296        (setf (link-href-end view) "html:a")
 297        (setf (link-ampersand view) "&amp;"))))
 298   view)
 299
 300
 301 ;;;; *************************************************************************
 302 ;;;;  View Data Format Section
 303 ;;;; *************************************************************************
 304
 305 (defun class-name-of (obj)
 306   (string-downcase (class-name (class-of obj))))
 307
 308 (defvar +newline-string+ (format nil "~%"))
 309
 310 (defun initialize-text-view (view)
 311   (setf (list-start-str-or-func view)
 312         (compile nil
 313                  #'(lambda (obj nitems strm)
 314                      (format strm "~a~P:~%"
 315                              (hyperobject-class-user-name obj) nitems))))
 316   (setf (list-start-indent view) t)
 317   (setf (obj-data-indent view) t)
 318   (setf (obj-data-end-str view) +newline-string+))
 319
 320 (defun html-list-start-func (obj nitems strm)
 321   (format strm "<p><b>~a~p:</b></p><div class=\""
 322           (hyperobject-class-user-name obj) nitems)
 323   (write-string (class-name-of obj))
 324   (write-string "\"><ul>~%" strm))
 325
 326 (defun initialize-html-view (view)
 327   (initialize-text-view view)
 328   (setf (file-start-str view) (format nil "<html><body>~%"))
 329   (setf (file-end-str view) (format nil "</body><html>~%"))
 330   (setf (list-start-indent view) t)
 331   (setf (list-start-str-or-func view) #'html-list-start-func)
 332   (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
 333   (setf (list-end-indent view) t)
 334   (setf (obj-start-indent view) t)
 335   (setf (obj-start-str-or-func view) "<li>")
 336   (setf (obj-end-indent view)  t)
 337   (setf (obj-end-str-or-func view)  (format nil "</li>~%"))
 338   (setf (obj-data-indent view) t))
 339
 340 (defun initialize-xhtml-view (view)
 341   (initialize-text-view view)
 342   (setf (file-start-str view) (format nil "<html><body>~%"))
 343   (setf (file-end-str view) (format nil "</body><html>~%"))
 344   (setf (list-start-indent view) t)
 345   (setf (list-start-str-or-func view) #'html-list-start-func)
 346   (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
 347   (setf (list-end-indent view) t)
 348   (setf (obj-start-indent view) t)
 349   (setf (obj-start-str-or-func view) "<li>")
 350   (setf (obj-end-indent view)  t)
 351   (setf (obj-end-str-or-func view) (format nil "</li>~%"))
 352   (setf (obj-data-indent view) t))
 353
 354 (defun xmlformat-list-end-func (x strm)
 355   (write-string "</" strm)
 356   (write-string (class-name-of x) strm)
 357   (write-string "list" strm)
 358   (write-string ">" strm)
 359   (write-char #\newline strm))
 360
 361 (defun xmlformat-list-start-func (x nitems strm)
 362   (write-char #\< strm)
 363   (write-string (class-name-of x) strm)
 364   (write-string "list><title>" strm)
 365   (format strm "~A~P:</title> ~%"
 366           (hyperobject-class-user-name x) nitems))
 367
 368 (defun initialize-xml-view (view)
 369   (initialize-text-view view)
 370   (setf (file-start-str view) "") ; (std-xml-header)
 371   (setf (list-start-indent view)  t)
 372   (setf (list-start-str-or-func view) #'xmlformat-list-start-func)
 373   (setf (list-end-indent view) t)
 374   (setf (list-end-str-or-func view) #'xmlformat-list-end-func)
 375   (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view)))
 376   (setf (obj-start-indent view) t)
 377   (setf (obj-end-str-or-func view) (format nil "</~(~a~)>~%" (object-class-name view)))
 378   (setf (obj-end-indent view) nil)
 379   (setf (obj-data-indent view) nil))
 380
 381
 382 ;;; File Start and Ends
 383
 384 (defun fmt-file-start (view strm)
 385   (awhen (file-start-str view)
 386          (write-string it strm)))
 387
 388 (defun fmt-file-end (view strm)
 389   (awhen (file-end-str view)
 390          (write-string it strm)))
 391
 392 ;;; List Start and Ends
 393
 394 (defun fmt-list-start (obj view strm indent num-items)
 395   (when (list-start-indent view)
 396     (indent-spaces indent strm))
 397   (awhen (list-start-str-or-func view)
 398          (if (stringp it)
 399              (write-string it strm)
 400              (funcall it obj num-items strm))))
 401
 402 (defun fmt-list-end (obj view strm indent num-items)
 403   (declare (ignore num-items))
 404   (when (list-end-indent view)
 405       (indent-spaces indent strm))
 406   (awhen (list-end-str-or-func view)
 407          (if (stringp it)
 408              (write-string it strm)
 409              (funcall it obj strm))))
 410
 411 ;;; Object Start and Ends
 412
 413 (defun fmt-obj-start (obj view strm indent)
 414   (when (obj-start-indent view)
 415     (indent-spaces indent strm))
 416   (awhen (obj-start-str-or-func view)
 417          (if (stringp it)
 418              (write-string it strm)
 419              (funcall it obj strm))))
 420
 421 (defun fmt-obj-end (obj view strm indent)
 422   (when (obj-end-indent view)
 423     (indent-spaces indent strm))
 424   (awhen (obj-end-str-or-func view)
 425          (if (stringp it)
 426              (write-string it strm)
 427              (funcall it obj strm))))
 428
 429 ;;; Object Data
 430
 431 (defun make-link-start (view fieldfunc fieldvalue refvars)
 432   (format nil "~a\"~a?func=~a~akey=~a~a\""
 433           (link-href-start view)
 434           (make-url (link-page-name view))
 435           fieldfunc
 436           (link-ampersand view) fieldvalue
 437           (if refvars
 438               (let ((varstr ""))
 439                 (dolist (var refvars)
 440                   (string-append
 441                    varstr (link-ampersand view)
 442                    (format nil "~a=~a" (car var) (cadr var))))
 443                 varstr)
 444               "")))
 445
 446 (defun make-link-end (obj view fieldname)
 447   (declare (ignore obj fieldname))
 448   (link-href-end view))
 449
 450 (defun fmt-obj-data (obj view strm indent refvars)
 451   (when (obj-data-indent view)
 452     (indent-spaces indent strm))
 453   (if (link-slots view)
 454       (fmt-obj-data-with-link obj view strm refvars)
 455       (fmt-obj-data-plain obj view strm))
 456   (awhen (obj-data-end-str view)
 457          (write-string it strm)))
 458
 459 (defun fmt-obj-data-plain (obj view strm)
 460   (awhen (obj-data-value-func view)
 461          (multiple-value-call #'format strm (obj-data-fmtstr view)
 462                               (funcall it obj))))
 463
 464 (defun fmt-obj-data-with-link (obj view strm refvars)
 465   (let ((refvalues '()))
 466     ;; make list of hyperlink link fields for printing to refstr template
 467     (dolist (name (link-slots view))
 468       (let-when (hyperlink
 469                  (find name (hyperobject-class-hyperlinks obj) :key #'name))
 470                 (push  (make-link-start view (lookup hyperlink) (slot-value obj name)
 471                                         (append (link-parameters hyperlink) refvars))
 472                        refvalues)
 473                 (push (make-link-end obj view name) refvalues)))
 474     (setq refvalues (nreverse refvalues))
 475     (apply #'format strm (make-link-data-str obj view) refvalues)))
 476
 477 (defun obj-data (obj view)
 478   "Returns the objects data as a string. Used by common-graphics outline function"
 479   (awhen (obj-data-value-func view)
 480          (multiple-value-call #'format nil (funcall (obj-data-fmtstr view))
 481                               (funcall it obj))))
 482
 483 (defun make-link-data-str (obj view)
 484   "Return fmt string for that contains ~a slots for hyperlink link start and end"
 485   (awhen (obj-data-value-func view)
 486          (multiple-value-call #'format nil (obj-data-fmtstr view)
 487                               (funcall it obj))))
 488
 489 ;;; Display method for objects
 490
 491
 492 (defun load-all-subobjects (objs)
 493   "Load all subobjects if they have not already been loaded."
 494   (dolist (obj (mklist objs))
 495     (dolist (subobj (hyperobject-class-subobjects obj))
 496       (awhen (slot-value obj (name-slot subobj))
 497              (load-all-subobjects it))))
 498   objs)
 499
 500 (defun view-hyperobject (objs view category strm &optional (indent 0) filter
 501                          subobjects refvars)
 502   "Display a single or list of hyperobject-class instances and their subobjects"
 503   (let-when (objlist (mklist objs))
 504     (let ((nobjs (length objlist))
 505           (*print-pretty* nil)
 506           (*print-circle* nil)
 507           (*print-escape* nil)
 508           (*print-readably* nil)
 509           (*print-length* nil)
 510           (*print-level* nil))
 511       (fmt-list-start (car objlist) view strm indent nobjs)
 512       (dolist (obj objlist)
 513         (unless (and filter (not (funcall filter obj)))
 514           (fmt-obj-start obj view strm indent)
 515           (fmt-obj-data obj view strm (1+ indent) refvars)
 516           (when (and subobjects (hyperobject-class-subobjects obj))
 517             (dolist (subobj (hyperobject-class-subobjects obj))
 518               (aif (slot-value obj (name-slot subobj))
 519                    (view-hyperobject it (get-category-view (car (mklist it)) category)
 520                                      category strm (1+ indent) filter
 521                                      subobjects refvars))))
 522           (fmt-obj-end obj view strm indent)))
 523       (fmt-list-end (car objlist) view strm indent nobjs)))
 524   objs)
 525
 526
 527 (defun view (objs &key (stream *standard-output*) category view
 528              filter subobjects refvars file-wrapper)
 529   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
 530   (let-when (objlist (mklist objs))
 531     (when category
 532       (setq view (get-category-view (car objlist) category)))
 533     (unless view
 534       (setq view (default-view (class-of (car objlist)))))
 535     (when file-wrapper
 536       (fmt-file-start view stream))
 537     (view-hyperobject objlist view category stream 0 filter subobjects refvars)
 538     (when file-wrapper
 539       (fmt-file-end view stream)))
 540   objs)
 541
 542
 543 ;;; Misc formatting
 544
 545 (defun fmt-comma-integer (i)
 546   (format nil "~:d" i))