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.4 2002/12/01 21:07:28 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 ;; 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     (setf (slot-value dsd 'ho-type) ho-type)
 160     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
 161     (setf (slot-value dsd 'sql-type) (ho-type-to-sql-type ho-type))
 162     (let ((ia (compute-effective-slot-definition-initargs
 163                cl #+lispworks name dsds)))
 164       (apply
 165        #'make-instance 'hyperobject-esd
 166        :ho-type ho-type
 167        :sql-type sql-type
 168        :print-formatter (slot-value dsd 'print-formatter)
 169        :subobject (slot-value dsd 'subobject)
 170        :hyperlink (slot-value dsd 'hyperlink)
 171        :description (slot-value dsd 'description)
 172        ia)))
 173   )
 174
 175 (defun ho-type-to-lisp-type (ho-type)
 176   (check-type ho-type symbol)
 177   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 178     (:string
 179      'string)
 180     (:fixnum
 181      'fixnum)
 182     (:boolean
 183      'boolean)
 184     (:integer
 185      'integer)
 186     (:cdata
 187      'string)
 188     (:float
 189      'float)
 190     (:nil
 191      t)
 192     (otherwise
 193      ho-type)))
 194
 195 (defun ho-type-to-sql-type (ho-type)
 196   (check-type ho-type symbol)
 197   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 198     (:string
 199      'string)
 200     (:fixnum
 201      'fixnum)
 202     (:boolean
 203      'boolean)
 204     (:integer
 205      'integer)
 206     (:cdata
 207      'string)
 208     (:float
 209      'float)
 210     (:nil
 211      t)
 212     (otherwise
 213      ho-type)))
 214
 215
 216
 217 (defun ho-type-to-sql-type (sqltype)
 218   (ecase sqltype
 219     (:string
 220      'string)
 221     (:fixnum
 222      'fixnum)
 223     (:bigint
 224      'integer)
 225     (:short-float
 226      'short-float)
 227     (:long
 228      'long-float)
 229     (:text
 230      'string)))
 231
 232 ;;;; Class initialization function
 233
 234 (defun process-subobjects (cl)
 235   "Process class subobjects slot"
 236   (setf (slot-value cl 'subobjects)
 237     (let ((subobjects '()))
 238       (dolist (slot (class-slots cl))
 239         (when (slot-value slot 'subobject)
 240           (push (make-instance 'subobject :name (slot-definition-name slot)
 241                                :reader (if (eq t (slot-value slot 'subobject))
 242                                            (slot-definition-name slot)
 243                                          (slot-value slot 'subobject)))
 244                 subobjects)))
 245       subobjects)))
 246
 247 (defun process-documentation (cl)
 248   "Calculate class documentation slot"
 249   (awhen (slot-value cl 'title)
 250          (setf (slot-value cl 'title) (car it)))
 251   (awhen (slot-value cl 'description)
 252          (setf (slot-value cl 'description) (car it)))
 253
 254   (let ((*print-circle* nil))
 255     (setf (documentation (class-name cl) 'class)
 256       (format nil "Hyperobject~A~A~A~A"
 257               (aif (slot-value cl 'title)
 258                    (format nil ": ~A" it ""))
 259               (aif (slot-value cl 'description)
 260                    (format nil "~%Class description: ~A" it) "")
 261               (aif (slot-value cl 'subobjects)
 262                    (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
 263               (aif (slot-value cl 'print-slots)
 264                    (format nil "~%Print-slots:~{ ~A~}" it) "")
 265               ))))
 266
 267 (defun init-hyperobject-class (cl)
 268   "Initialize a hyperobject class. Calculates all class slots"
 269   (process-subobjects cl)
 270   (process-views cl)
 271   (process-sql cl)
 272   (process-documentation cl))
 273
 274
 275 ;;;; *************************************************************************
 276 ;;;;  Metaclass Slot Accessors
 277 ;;;; *************************************************************************
 278
 279 (defun find-slot-by-name (cl name)
 280   (find name (class-slots cl) :key #'slot-definition-name))
 281
 282 (defun hyperobject-class-fmtstr-text (obj)
 283   (slot-value (class-of obj) 'fmtstr-text))
 284
 285 (defun hyperobject-class-fmtstr-html (obj)
 286   (slot-value (class-of obj) 'fmtstr-html))
 287
 288 (defun hyperobject-class-fmtstr-xml (obj)
 289   (slot-value (class-of obj) 'fmtstr-xml))
 290
 291 (defun hyperobject-class-fmtstr-text-labels (obj)
 292   (slot-value (class-of obj) 'fmtstr-text-labels))
 293
 294 (defun hyperobject-class-fmtstr-html-labels (obj)
 295   (slot-value (class-of obj) 'fmtstr-html-labels))
 296
 297 (defun hyperobject-class-fmtstr-xml-labels (obj)
 298   (slot-value (class-of obj) 'fmtstr-xml-labels))
 299
 300 (defun hyperobject-class-value-func (obj)
 301   (slot-value (class-of obj) 'value-func))
 302
 303 (defun hyperobject-class-xmlvalue-func (obj)
 304   (slot-value (class-of obj) 'xmlvalue-func))
 305
 306 (eval-when (:compile-toplevel :load-toplevel :execute)
 307
 308   (defun hyperobject-class-title (obj)
 309     (awhen (slot-value (class-of obj) 'title)
 310            (if (consp it)
 311                (car it)
 312                it))))
 313
 314 (defun hyperobject-class-subobjects (obj)
 315   (slot-value (class-of obj) 'subobjects))
 316
 317 (defun hyperobject-class-hyperlinks (obj)
 318   (slot-value (class-of obj) 'hyperlinks))
 319
 320 (defun hyperobject-class-fields (obj)
 321   (class-slots (class-of obj)))
 322
 323 (defun hyperobject-class-fmtstr-html-ref (obj)
 324   (slot-value (class-of obj) 'fmtstr-html-ref))
 325
 326 (defun hyperobject-class-fmtstr-xml-ref (obj)
 327   (slot-value (class-of obj) 'fmtstr-xml-ref))
 328
 329 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 330   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 331
 332 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 333   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 334