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.16 2002/11/25 07:45:35 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    #+scl
  52    `(class-of  class-name clos:class-slots clos::standard-class
  53      clos::slot-definition-name clos:finalize-inheritance
  54      clos::standard-direct-slot-definition clos::standard-effective-slot-definition
  55      clos::validate-superclass clos:direct-slot-definition-class
  56      clos:compute-effective-slot-definition
  57      clos::compute-effective-slot-definition-initargs)
  58
  59    :hyperobject))
  60
  61
  62 ;; Main class
  63
  64 (defclass hyperobject-class (standard-class)
  65   ( ;; slots initialized in defclass
  66    (title :initarg :title :type string :initform nil
  67           :documentation "Print Title for class")
  68    (print-slots :initarg :print-slots :type list :initform nil
  69                 :documentation "List of slots to print")
  70    (description :initarg :description :initform nil
  71                 :documentation "Class description")
  72
  73    ;;; The remainder of these fields are calculated one time
  74    ;;; in finalize-inheritence.
  75
  76    (subobjects :initform nil :documentation
  77                "List of fields that contain a list of subobjects objects.")
  78    (references :type list :initform nil :documentation
  79                "List of fields that have references")
  80
  81    (value-func :initform nil :type function)
  82    (xmlvalue-func :initform nil :type function)
  83    (fmtstr-text :initform nil :type string)
  84    (fmtstr-html :initform nil :type string)
  85    (fmtstr-xml :initform nil :type string)
  86    (fmtstr-text-labels :initform nil :type string)
  87    (fmtstr-html-labels :initform nil :type string)
  88    (fmtstr-xml-labels :initform nil :type string)
  89    (fmtstr-html-ref :initform nil :type string)
  90    (fmtstr-xml-ref :initform nil :type string)
  91    (fmtstr-html-ref-labels :initform nil :type string)
  92    (fmtstr-xml-ref-labels :initform nil :type string)
  93    )
  94   (:documentation "Metaclass for Markup Language classes."))
  95
  96 (defclass subobject ()
  97   ((name :type symbol :initform nil :initarg :name :reader name)
  98    (reader :type function :initform nil :initarg :reader :reader reader)))
  99
 100 (defmethod print-object ((obj subobject) (s stream))
 101   (print-unreadable-object (obj s :type t :identity t)
 102     (format s "~S" (name obj))))
 103
 104 (defclass reference ()
 105   ((name :type symbol :initform nil :initarg :name :reader name)
 106    (lookup :type function :initform nil :initarg :lookup :reader lookup)
 107    (link-parameters :type list :initform nil :initarg :link-parameters
 108                     :reader link-parameters)))
 109
 110 (defmethod print-object ((obj reference) (s stream))
 111   (print-unreadable-object (obj s :type t :identity t)
 112     (format s "~S" (name obj))))
 113
 114 #+(or cmu scl sbcl)
 115 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
 116   t)
 117
 118 (defmethod finalize-inheritance :after ((cl hyperobject-class))
 119   (init-hyperobject-class cl))
 120
 121 ;; Slot definitions
 122 (defmethod direct-slot-definition-class ((cl hyperobject-class)
 123                                          #+allegro &rest
 124                                                    iargs)
 125   (find-class 'hyperobject-dsd))
 126
 127 (defmacro define-class-option (slot-name &optional required)
 128   #+lispworks
 129   `(defmethod clos:process-a-class-option ((class hyperobject-class)
 130                                            (name (eql ,slot-name))
 131                                            value)
 132     (when (and ,required (null value))
 133       (error "hyperobject class slot ~A must have a value" name))
 134     (list name `',value))
 135   #+(or allegro sbcl cmu scl)
 136   (declare (ignore slot-name required))
 137   )
 138
 139 (defmacro define-slot-option (slot-name)
 140   #+lispworks
 141   `(defmethod clos:process-a-slot-option ((class hyperobject-class)
 142                                           (option (eql ,slot-name))
 143                                           value
 144                                           already-processed-other-options
 145                                           slot)
 146     (list option `',value))
 147   #-lispworks
 148   (declare (ignore slot-name))
 149   )
 150
 151 (define-class-option :title)
 152 (define-class-option :print-slots)
 153 (define-class-option :description)
 154
 155 (define-slot-option :print-formatter)
 156 (define-slot-option :subobject)
 157 (define-slot-option :reference)
 158 (define-slot-option :description)
 159
 160 ;; Slot definitions
 161
 162 (defclass hyperobject-dsd (standard-direct-slot-definition)
 163   ((ho-type :initarg :ho-type :initform nil)
 164    (print-formatter :initarg :print-formatter :initform nil)
 165    (subobject :initarg :subobject :initform nil)
 166    (reference :initarg :reference :initform nil)
 167    (description :initarg :description :initform nil)
 168    ))
 169
 170 (defclass hyperobject-esd (standard-effective-slot-definition)
 171   ((ho-type :initarg :ho-type :accessor esd-ho-type :initform nil)
 172    (print-formatter :initarg :print-formatter :accessor esd-print-formatter
 173                     :initform nil)
 174    (subobject :initarg :subobject :accessor esd-subobject :initform nil)
 175    (reference :initarg :reference :accessor esd-reference :initform nil)
 176    (description :initarg :description :accessor esd-description :initform nil)
 177   ))
 178
 179
 180 (defmethod compute-effective-slot-definition :around
 181     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
 182   #+allergo (declare (ignore name))
 183   (let* ((dsd (car dsds))
 184          (ho-type (slot-value dsd 'type)))
 185     (setf (slot-value dsd 'ho-type) ho-type)
 186     (setf (slot-value dsd 'type) (convert-ho-type ho-type))
 187     (let ((ia (compute-effective-slot-definition-initargs
 188                cl #+lispworks name dsds)))
 189       (apply
 190        #'make-instance 'hyperobject-esd
 191        :ho-type ho-type
 192        :print-formatter (slot-value dsd 'print-formatter)
 193        :subobject (slot-value dsd 'subobject)
 194        :reference (slot-value dsd 'reference)
 195        :description (slot-value dsd 'description)
 196        ia)))
 197   )
 198
 199 (defun convert-ho-type (ho-type)
 200   (check-type ho-type symbol)
 201   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 202     (:string
 203      'string)
 204     (:fixnum
 205      'fixnum)
 206     (:boolean
 207      'boolean)
 208     (:integer
 209      'integer)
 210     (:cdata
 211      'string)
 212     (:float
 213      'float)
 214     (:nil
 215      t)
 216     (otherwise
 217      ho-type)))
 218
 219 ;;;; Class initialization function
 220
 221 (defun find-slot-by-name (cl name)
 222   (find name (class-slots cl) :key #'slot-definition-name))
 223
 224
 225 (defun process-subobjects (cl)
 226   "Process class subobjects slot"
 227   (setf (slot-value cl 'subobjects)
 228     (let ((subobjects '()))
 229       (dolist (slot (class-slots cl))
 230         (when (slot-value slot 'subobject)
 231           (push (make-instance 'subobject :name (slot-definition-name slot)
 232                                :reader (if (eq t (esd-subobject slot))
 233                                            (slot-definition-name slot)
 234                                          (esd-subobject slot)))
 235                 subobjects)))
 236       subobjects)))
 237
 238 (defun process-documentation (cl)
 239   "Calculate class documentation slot"
 240   (awhen (slot-value cl 'title)
 241          (setf (slot-value cl 'title) (car it)))
 242   (awhen (slot-value cl 'description)
 243          (setf (slot-value cl 'description) (car it)))
 244
 245   (let ((*print-circle* nil))
 246     (setf (documentation (class-name cl) 'class)
 247       (format nil "Hyperobject~A~A~A~A"
 248               (aif (slot-value cl 'title)
 249                    (format nil ": ~A" it ""))
 250               (aif (slot-value cl 'description)
 251                    (format nil "~%Class description: ~A" it) "")
 252               (aif (slot-value cl 'subobjects)
 253                    (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
 254               (aif (slot-value cl 'print-slots)
 255                    (format nil "~%Print-slots:~{ ~A~}" it) "")
 256               ))))
 257
 258 (defun process-views (cl)
 259   "Calculate all view slots for a hyperobject class"
 260   (let ((fmtstr-text "")
 261         (fmtstr-html "")
 262         (fmtstr-xml "")
 263         (fmtstr-text-labels "")
 264         (fmtstr-html-labels "")
 265         (fmtstr-xml-labels "")
 266         (fmtstr-html-ref "")
 267         (fmtstr-xml-ref "")
 268         (fmtstr-html-ref-labels "")
 269         (fmtstr-xml-ref-labels "")
 270         (first-field t)
 271         (value-func '())
 272         (xmlvalue-func '())
 273         (classname (class-name cl))
 274         (package (symbol-package (class-name cl)))
 275         (references nil))
 276     (declare (ignore classname))
 277     (check-type (slot-value cl 'print-slots) list)
 278     (dolist (slot-name (slot-value cl 'print-slots))
 279       (let ((slot (find-slot-by-name cl slot-name)))
 280         (unless slot
 281           (error "Slot ~A is not found in class ~S" slot-name cl))
 282         (let ((name (slot-definition-name slot))
 283               (namestr (symbol-name (slot-definition-name slot)))
 284               (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
 285               (type (slot-value slot 'ho-type))
 286               (print-formatter (slot-value slot 'print-formatter))
 287               (value-fmt "~a")
 288               (plain-value-func nil)
 289               html-str xml-str html-label-str xml-label-str)
 290
 291           (when (or (eql type :integer) (eql type :fixnum))
 292             (setq value-fmt "~d"))
 293
 294           (when (eql type :boolean)
 295             (setq value-fmt "~a"))
 296
 297           (if first-field
 298               (setq first-field nil)
 299               (progn
 300                 (string-append fmtstr-text " ")
 301                 (string-append fmtstr-html " ")
 302                 (string-append fmtstr-xml " ")
 303                 (string-append fmtstr-text-labels " ")
 304                 (string-append fmtstr-html-labels " ")
 305                 (string-append fmtstr-xml-labels " ")
 306                 (string-append fmtstr-html-ref " ")
 307                 (string-append fmtstr-xml-ref " ")
 308                 (string-append fmtstr-html-ref-labels " ")
 309                 (string-append fmtstr-xml-ref-labels " ")))
 310
 311           (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
 312           (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 313           (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
 314           (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 315
 316           (string-append fmtstr-text value-fmt)
 317           (string-append fmtstr-html html-str)
 318           (string-append fmtstr-xml xml-str)
 319           (string-append fmtstr-text-labels namestr-lower " " value-fmt)
 320           (string-append fmtstr-html-labels html-label-str)
 321           (string-append fmtstr-xml-labels xml-label-str)
 322
 323           (if (esd-reference slot)
 324               (progn
 325                 (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
 326                 (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
 327                 (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 328                 (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
 329                 (push (make-instance 'reference :name name :lookup (esd-reference slot))
 330                       references))
 331               (progn
 332                 (string-append fmtstr-html-ref html-str)
 333                 (string-append fmtstr-xml-ref xml-str)
 334                 (string-append fmtstr-html-ref-labels html-label-str)
 335                 (string-append fmtstr-xml-ref-labels xml-label-str)))
 336
 337           (if print-formatter
 338               (setq plain-value-func
 339                     (list `(,print-formatter (slot-value x ',(intern namestr package)))))
 340               (setq plain-value-func
 341                     (list `(slot-value x ',(intern namestr package)))))
 342           (setq value-func (append value-func plain-value-func))
 343
 344           (if (eql type :cdata)
 345               (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
 346               (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
 347           )))
 348
 349     (setf (slot-value cl 'references) references)
 350
 351     (if value-func
 352         (setq value-func `(lambda (x) (values ,@value-func)))
 353         (setq value-func `(lambda () (values))))
 354     (setq value-func (compile nil (eval value-func)))
 355
 356     (if xmlvalue-func
 357         (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 358         (setq xmlvalue-func `(lambda () (values))))
 359     (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
 360
 361     (setf (slot-value cl 'fmtstr-text) fmtstr-text)
 362     (setf (slot-value cl 'fmtstr-html) fmtstr-html)
 363     (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
 364     (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
 365     (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
 366     (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
 367     (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
 368     (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
 369     (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
 370     (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
 371     (setf (slot-value cl 'value-func) value-func)
 372     (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
 373   (values))
 374
 375 (defun init-hyperobject-class (cl)
 376   "Initialize a hyperobject class. Calculates all class slots"
 377   (process-subobjects cl)
 378   (process-views cl)
 379   (process-documentation cl))
 380
 381 (defun hyperobject-class-fmtstr-text (obj)
 382   (slot-value (class-of obj) 'fmtstr-text))
 383
 384 (defun hyperobject-class-fmtstr-html (obj)
 385   (slot-value (class-of obj) 'fmtstr-html))
 386
 387 (defun hyperobject-class-fmtstr-xml (obj)
 388   (slot-value (class-of obj) 'fmtstr-xml))
 389
 390 (defun hyperobject-class-fmtstr-text-labels (obj)
 391   (slot-value (class-of obj) 'fmtstr-text-labels))
 392
 393 (defun hyperobject-class-fmtstr-html-labels (obj)
 394   (slot-value (class-of obj) 'fmtstr-html-labels))
 395
 396 (defun hyperobject-class-fmtstr-xml-labels (obj)
 397   (slot-value (class-of obj) 'fmtstr-xml-labels))
 398
 399 (defun hyperobject-class-value-func (obj)
 400   (slot-value (class-of obj) 'value-func))
 401
 402 (defun hyperobject-class-xmlvalue-func (obj)
 403   (slot-value (class-of obj) 'xmlvalue-func))
 404
 405 (eval-when (:compile-toplevel :load-toplevel :execute)
 406 (defun hyperobject-class-title (obj)
 407   (awhen (slot-value (class-of obj) 'title)
 408             (if (consp it)
 409                 (car it)
 410               it))))
 411
 412 (defun hyperobject-class-subobjects (obj)
 413   (slot-value (class-of obj) 'subobjects))
 414
 415 (defun hyperobject-class-references (obj)
 416   (slot-value (class-of obj) 'references))
 417
 418 (defun hyperobject-class-fields (obj)
 419   (class-slots (class-of obj)))
 420
 421 (defun hyperobject-class-fmtstr-html-ref (obj)
 422   (slot-value (class-of obj) 'fmtstr-html-ref))
 423
 424 (defun hyperobject-class-fmtstr-xml-ref (obj)
 425   (slot-value (class-of obj) 'fmtstr-xml-ref))
 426
 427 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 428   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 429
 430 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 431   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 432