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