mop.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          mop.lisp
   6 ;;;; Purpose:       Metaobject Protocol Interface
   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.6 2002/12/05 19:15:02 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 2) (safety 2) (compilation-speed 0) (debug 2))))
  24
  25 ;; Main class
  26
  27 (defclass hyperobject-class (standard-class)
  28   ( ;; slots initialized in defclass
  29    (title :initarg :title :type string :initform nil
  30           :documentation "Print Title for class")
  31    (print-slots :initarg :print-slots :type list :initform nil
  32                 :documentation "List of slots to print")
  33    (description :initarg :description :initform nil
  34                 :documentation "Class description")
  35    (version :initarg :version :initform nil
  36                 :documentation "Version number for class")
  37    (sql-name :initarg :table-name :initform nil :reader sql-name)
  38
  39    ;;; The remainder of these fields are calculated one time
  40    ;;; in finalize-inheritence.
  41
  42    (subobjects :initform nil :documentation
  43                "List of fields that contain a list of subobjects objects.")
  44    (hyperlinks :type list :initform nil :documentation
  45                "List of fields that have hyperlinks")
  46    (class-id :type integer :initform nil :documentation
  47              "Unique ID for the class")
  48
  49    (create-table-cmd :initform nil :reader create-table-cmd)
  50    (create-index-cmds :initform nil :reader create-index-cmds)
  51    (drop-table-cmd :initform nil :reader drop-table-cmd)
  52
  53    (value-func :initform nil :type function)
  54    (xmlvalue-func :initform nil :type function)
  55    (fmtstr-text :initform nil :type string)
  56    (fmtstr-html :initform nil :type string)
  57    (fmtstr-xml :initform nil :type string)
  58    (fmtstr-text-labels :initform nil :type string)
  59    (fmtstr-html-labels :initform nil :type string)
  60    (fmtstr-xml-labels :initform nil :type string)
  61    (fmtstr-html-ref :initform nil :type string)
  62    (fmtstr-xml-ref :initform nil :type string)
  63    (fmtstr-html-ref-labels :initform nil :type string)
  64    (fmtstr-xml-ref-labels :initform nil :type string)
  65    )
  66   (:documentation "Metaclass for Markup Language classes."))
  67
  68 (defclass subobject ()
  69   ((name :type symbol :initform nil :initarg :name :reader name)
  70    (reader :type function :initform nil :initarg :reader :reader reader)))
  71
  72 (defmethod print-object ((obj subobject) (s stream))
  73   (print-unreadable-object (obj s :type t :identity t)
  74     (format s "~S" (name obj))))
  75
  76 (defclass hyperlink ()
  77   ((name :type symbol :initform nil :initarg :name :reader name)
  78    (lookup :type function :initform nil :initarg :lookup :reader lookup)
  79    (link-parameters :type list :initform nil :initarg :link-parameters
  80                     :reader link-parameters)))
  81
  82 (defmethod print-object ((obj hyperlink) (s stream))
  83   (print-unreadable-object (obj s :type t :identity t)
  84     (format s "~S" (name obj))))
  85
  86 #+(or cmu scl sbcl)
  87 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
  88   t)
  89
  90 (defmethod finalize-inheritance :after ((cl hyperobject-class))
  91   (init-hyperobject-class cl))
  92
  93 ;; Slot definitions
  94 (defmethod direct-slot-definition-class ((cl hyperobject-class)
  95                                          #+allegro &rest
  96                                                    iargs)
  97   (find-class 'hyperobject-dsd))
  98
  99
 100 ; Slot definitions
 101
 102 (eval-when (:compile-toplevel :load-toplevel :execute)
 103   (defmacro process-class-option (slot-name &optional required)
 104     #+lispworks
 105     `(defmethod clos:process-a-class-option ((class hyperobject-class)
 106                                              (name (eql ,slot-name))
 107                                              value)
 108     (when (and ,required (null value))
 109       (error "hyperobject class slot ~A must have a value" name))
 110     (list name `',value))
 111     #+(or allegro sbcl cmu scl)
 112     (declare (ignore slot-name required))
 113     )
 114
 115   (defmacro process-slot-option (slot-name)
 116     #+lispworks
 117     `(defmethod clos:process-a-slot-option ((class hyperobject-class)
 118                                             (option (eql ,slot-name))
 119                                             value
 120                                           already-processed-other-options
 121                                             slot)
 122        (list option `',value))
 123     #-lispworks
 124     (declare (ignore slot-name))
 125     )
 126
 127   (dolist (option *class-options*)
 128     (eval `(process-class-option ,option)))
 129   (dolist (option *slot-options*)
 130     (eval `(process-slot-option ,option)))
 131
 132   (eval
 133    `(defclass hyperobject-dsd (standard-direct-slot-definition)
 134       (,@(mapcar #'(lambda (x)
 135                      `(,(intern (symbol-name x))
 136                         :initform nil))
 137                  *slot-options-no-initarg*)
 138          ,@(mapcar #'(lambda (x)
 139                        `(,(intern (symbol-name x))
 140                           :initarg
 141                           ,(intern (symbol-name x) (symbol-name :keyword))
 142                           :initform nil))
 143                    *slot-options*))))
 144   (eval
 145    `(defclass hyperobject-esd (standard-effective-slot-definition)
 146       (,@(mapcar #'(lambda (x)
 147                      `(,(intern (symbol-name x))
 148                         :initarg
 149                         ,(intern (symbol-name x) (symbol-name :keyword))
 150                         :initform nil))
 151                   (append *slot-options* *slot-options-no-initarg*)))))
 152   ) ;; eval-when
 153
 154 (defmethod compute-effective-slot-definition :around
 155     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
 156   #+allergo (declare (ignore name))
 157   (let* ((dsd (car dsds))
 158          (ho-type (slot-value dsd 'type))
 159          (sql-type (ho-type-to-sql-type ho-type)))
 160     (setf (slot-value dsd 'ho-type) ho-type)
 161     (setf (slot-value dsd 'sql-type) sql-type)
 162     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
 163     (let ((ia (compute-effective-slot-definition-initargs
 164                cl #+lispworks name dsds)))
 165       (apply
 166        #'make-instance 'hyperobject-esd
 167        :ho-type ho-type
 168        :sql-type sql-type
 169        :print-formatter (slot-value dsd 'print-formatter)
 170        :subobject (slot-value dsd 'subobject)
 171        :hyperlink (slot-value dsd 'hyperlink)
 172        :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
 173        :description (slot-value dsd 'description)
 174        ia))))
 175
 176 (defun ho-type-to-lisp-type (ho-type)
 177   (check-type ho-type symbol)
 178   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 179     (:string
 180      'string)
 181     (:fixnum
 182      'fixnum)
 183     (:boolean
 184      'boolean)
 185     (:integer
 186      'integer)
 187     (:cdata
 188      'string)
 189     (:float
 190      'float)
 191     (:nil
 192      t)
 193     (otherwise
 194      ho-type)))
 195
 196 (defun ho-type-to-sql-type (ho-type)
 197   (check-type ho-type symbol)
 198   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 199     (:string
 200      'string)
 201     (:fixnum
 202      'integer)
 203     (:boolean
 204      'boolean)
 205     (:integer
 206      'integer)
 207     (:cdata
 208      'string)
 209     (:float
 210      'float)
 211     (:nil
 212      t)
 213     (otherwise
 214      ho-type)))
 215
 216
 217 ;;;; Class initialization function
 218
 219 (defun finalize-subobjects (cl)
 220   "Process class subobjects slot"
 221   (setf (slot-value cl 'subobjects)
 222     (let ((subobjects '()))
 223       (dolist (slot (class-slots cl))
 224         (when (slot-value slot 'subobject)
 225           (push (make-instance 'subobject :name (slot-definition-name slot)
 226                                :reader (if (eq t (slot-value slot 'subobject))
 227                                            (slot-definition-name slot)
 228                                          (slot-value slot 'subobject)))
 229                 subobjects)))
 230       subobjects)))
 231
 232 (defun finalize-documentation (cl)
 233   "Calculate class documentation slot"
 234   (awhen (slot-value cl 'title)
 235          (setf (slot-value cl 'title)
 236                (etypecase (slot-value cl 'title)
 237                    (cons (car it))
 238                    ((or string symbol) it))))
 239   (awhen (slot-value cl 'description)
 240          (setf (slot-value cl 'description)
 241                (etypecase (slot-value cl 'description)
 242                    (cons (car it))
 243                    ((or string symbol) 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 init-hyperobject-class (cl)
 259   "Initialize a hyperobject class. Calculates all class slots"
 260   (finalize-subobjects cl)
 261   (finalize-views cl)
 262   (finalize-hyperlinks cl)
 263   (finalize-sql cl)
 264   (finalize-documentation cl))
 265
 266
 267 ;;;; *************************************************************************
 268 ;;;;  Metaclass Slot Accessors
 269 ;;;; *************************************************************************
 270
 271 (defun find-slot-by-name (cl name)
 272   (find name (class-slots cl) :key #'slot-definition-name))
 273
 274 (defun hyperobject-class-fmtstr-text (obj)
 275   (slot-value (class-of obj) 'fmtstr-text))
 276
 277 (defun hyperobject-class-fmtstr-html (obj)
 278   (slot-value (class-of obj) 'fmtstr-html))
 279
 280 (defun hyperobject-class-fmtstr-xml (obj)
 281   (slot-value (class-of obj) 'fmtstr-xml))
 282
 283 (defun hyperobject-class-fmtstr-text-labels (obj)
 284   (slot-value (class-of obj) 'fmtstr-text-labels))
 285
 286 (defun hyperobject-class-fmtstr-html-labels (obj)
 287   (slot-value (class-of obj) 'fmtstr-html-labels))
 288
 289 (defun hyperobject-class-fmtstr-xml-labels (obj)
 290   (slot-value (class-of obj) 'fmtstr-xml-labels))
 291
 292 (defun hyperobject-class-value-func (obj)
 293   (slot-value (class-of obj) 'value-func))
 294
 295 (defun hyperobject-class-xmlvalue-func (obj)
 296   (slot-value (class-of obj) 'xmlvalue-func))
 297
 298 (eval-when (:compile-toplevel :load-toplevel :execute)
 299
 300   (defun hyperobject-class-title (obj)
 301     (awhen (slot-value (class-of obj) 'title)
 302            (if (consp it)
 303                (car it)
 304                it))))
 305
 306 (defun hyperobject-class-subobjects (obj)
 307   (slot-value (class-of obj) 'subobjects))
 308
 309 (defun hyperobject-class-hyperlinks (obj)
 310   (slot-value (class-of obj) 'hyperlinks))
 311
 312 (defun hyperobject-class-fields (obj)
 313   (class-slots (class-of obj)))
 314
 315 (defun hyperobject-class-print-slots (obj)
 316   (slot-value (class-of obj) 'print-slots))
 317
 318 (defun hyperobject-class-fmtstr-html-ref (obj)
 319   (slot-value (class-of obj) 'fmtstr-html-ref))
 320
 321 (defun hyperobject-class-fmtstr-xml-ref (obj)
 322   (slot-value (class-of obj) 'fmtstr-xml-ref))
 323
 324 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 325   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 326
 327 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 328   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 329