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