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.8 2002/12/09 10:39:38 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    (user-name :initarg :user-name :type string :initform nil
  30           :documentation "User name 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)
  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-indices-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-class :type symbol :initform nil :initarg :name-class :reader name-class)
  70    (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
  71    (lookup :type symbol :initform nil :initarg :lookup :reader lookup)
  72    (lookup-keys :type list :initform nil :initarg :lookup-keys
  73                 :reader lookup-keys))
  74   (:documentation "Contains subobject information"))
  75
  76
  77 (defmethod print-object ((obj subobject) (s stream))
  78   (print-unreadable-object (obj s :type t :identity t)
  79     (format s "~S" (name obj))))
  80
  81 (defclass hyperlink ()
  82   ((name :type symbol :initform nil :initarg :name :reader name)
  83    (lookup :type function :initform nil :initarg :lookup :reader lookup)
  84    (link-parameters :type list :initform nil :initarg :link-parameters
  85                     :reader link-parameters)))
  86
  87 (defmethod print-object ((obj hyperlink) (s stream))
  88   (print-unreadable-object (obj s :type t :identity t)
  89     (format s "~S" (name obj))))
  90
  91 #+(or cmu scl sbcl)
  92 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
  93   t)
  94
  95 (defmethod finalize-inheritance :after ((cl hyperobject-class))
  96   (init-hyperobject-class cl))
  97
  98 ;; Slot definitions
  99 (defmethod direct-slot-definition-class ((cl hyperobject-class)
 100                                          #+allegro &rest
 101                                                    iargs)
 102   (find-class 'hyperobject-dsd))
 103
 104
 105 ; Slot definitions
 106
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (defmacro process-class-option (slot-name &optional required)
 109     #+lispworks
 110     `(defmethod clos:process-a-class-option ((class hyperobject-class)
 111                                              (name (eql ,slot-name))
 112                                              value)
 113     (when (and ,required (null value))
 114       (error "hyperobject class slot ~A must have a value" name))
 115     (list name `',value))
 116     #+(or allegro sbcl cmu scl)
 117     (declare (ignore slot-name required))
 118     )
 119
 120   (defmacro process-slot-option (slot-name)
 121     #+lispworks
 122     `(defmethod clos:process-a-slot-option ((class hyperobject-class)
 123                                             (option (eql ,slot-name))
 124                                             value
 125                                           already-processed-other-options
 126                                             slot)
 127        (list option `',value))
 128     #-lispworks
 129     (declare (ignore slot-name))
 130     )
 131
 132   (dolist (option *class-options*)
 133     (eval `(process-class-option ,option)))
 134   (dolist (option *slot-options*)
 135     (eval `(process-slot-option ,option)))
 136
 137   (eval
 138    `(defclass hyperobject-dsd (standard-direct-slot-definition)
 139       (,@(mapcar #'(lambda (x)
 140                      `(,(intern (symbol-name x))
 141                         :initform nil))
 142                  *slot-options-no-initarg*)
 143          ,@(mapcar #'(lambda (x)
 144                        `(,(intern (symbol-name x))
 145                           :initarg
 146                           ,(intern (symbol-name x) (symbol-name :keyword))
 147                           :initform nil))
 148                    *slot-options*))))
 149   (eval
 150    `(defclass hyperobject-esd (standard-effective-slot-definition)
 151       (,@(mapcar #'(lambda (x)
 152                      `(,(intern (symbol-name x))
 153                         :initarg
 154                         ,(intern (symbol-name x) (symbol-name :keyword))
 155                         :initform nil))
 156                   (append *slot-options* *slot-options-no-initarg*)))))
 157   ) ;; eval-when
 158
 159 (defmethod compute-effective-slot-definition :around
 160     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
 161   #+allergo (declare (ignore name))
 162   (let* ((dsd (car dsds))
 163          (ho-type (slot-value dsd 'type))
 164          (sql-type (ho-type-to-sql-type ho-type))
 165          (length (when (consp ho-type) (cadr ho-type))))
 166     (setf (slot-value dsd 'ho-type) ho-type)
 167     (setf (slot-value dsd 'sql-type) sql-type)
 168     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
 169     (let ((ia (compute-effective-slot-definition-initargs
 170                cl #+lispworks name dsds)))
 171       (apply
 172        #'make-instance 'hyperobject-esd
 173        :ho-type ho-type
 174        :sql-type sql-type
 175        :length length
 176        :print-formatter (slot-value dsd 'print-formatter)
 177        :subobject (slot-value dsd 'subobject)
 178        :hyperlink (slot-value dsd 'hyperlink)
 179        :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
 180        :description (slot-value dsd 'description)
 181        :user-name (slot-value dsd 'user-name)
 182        :index (slot-value dsd 'index)
 183        ia))))
 184
 185 (defun ho-type-to-lisp-type (ho-type)
 186   (when (consp ho-type)
 187     (setq ho-type (car ho-type)))
 188   (check-type ho-type symbol)
 189   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 190     ((or :string :cdata :varchar :char)
 191      'string)
 192     (:character
 193      'character)
 194     (:fixnum
 195      'fixnum)
 196     (:boolean
 197      'boolean)
 198     (:integer
 199      'integer)
 200     ((or :float :single-float)
 201      'single-float)
 202     (:double-float
 203      'double-float)
 204     (:nil
 205      t)
 206     (otherwise
 207      ho-type)))
 208
 209 (defun ho-type-to-sql-type (ho-type)
 210   (when (consp ho-type)
 211     (setq ho-type (car ho-type)))
 212   (check-type ho-type symbol)
 213   (case (intern (symbol-name ho-type) (symbol-name :keyword))
 214     ((or :string :cdata)
 215      'string)
 216     (:fixnum
 217      'integer)
 218     (:boolean
 219      'boolean)
 220     (:integer
 221      'integer)
 222     ((or :float :single-float)
 223      'single-float)
 224     (:double-float
 225      'double-float)
 226     (:nil
 227      t)
 228     (otherwise
 229      ho-type)))
 230
 231
 232 ;;;; Class initialization function
 233
 234 ;; defines a slot-unbound method for class and slot-name, fills
 235 ;; the slot by calling reader function with the slot values of
 236 ;; the instance's reader-keys
 237 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
 238   (let* ((the-slot-name (gensym))
 239          (the-class (gensym))
 240          (the-instance (gensym))
 241          (keys '()))
 242     (dolist (key reader-keys)
 243       (push (list 'slot-value the-instance (list 'quote key)) keys))
 244     (setq keys (nreverse keys))
 245     `(defmethod slot-unbound (,the-class (,the-instance ,class)
 246                                          (,the-slot-name (eql ',slot-name)))
 247        (declare (ignore ,the-class))
 248        (setf (slot-value ,the-instance ,the-slot-name)
 249            (,reader ,@keys)))))
 250
 251 (defun finalize-subobjects (cl)
 252   "Process class subobjects slot"
 253   (setf (slot-value cl 'subobjects)
 254     (let ((subobjects '()))
 255       (dolist (slot (class-slots cl))
 256         (let-when (subobj-def (slot-value slot 'subobject))
 257           (let ((subobject (make-instance 'subobject
 258                                           :name-class (class-name cl)
 259                                           :name-slot (slot-definition-name slot)
 260                                           :lookup (if (atom subobj-def)
 261                                                       subobj-def
 262                                                       (car subobj-def))
 263                                           :lookup-keys (if (atom subobj-def)
 264                                                            nil
 265                                                            (cdr subobj-def)))))
 266             (unless (eq (lookup subobject) t)
 267               (eval `(def-lazy-reader ,(name-class subobject)
 268                          ,(name-slot subobject) ,(lookup subobject)
 269                          ,@(lookup-keys subobject))))
 270             (push subobject subobjects))))
 271       subobjects)))
 272
 273 (defun finalize-documentation (cl)
 274   "Calculate class documentation slot"
 275   (awhen (slot-value cl 'user-name)
 276          (setf (slot-value cl 'user-name)
 277                (etypecase (slot-value cl 'user-name)
 278                    (cons (car it))
 279                    ((or string symbol) it))))
 280   (awhen (slot-value cl 'description)
 281          (setf (slot-value cl 'description)
 282                (etypecase (slot-value cl 'description)
 283                    (cons (car it))
 284                    ((or string symbol) it))))
 285
 286   (let ((*print-circle* nil))
 287     (setf (documentation (class-name cl) 'class)
 288       (format nil "Hyperobject~A~A~A~A"
 289               (aif (slot-value cl 'user-name)
 290                    (format nil ": ~A" it ""))
 291               (aif (slot-value cl 'description)
 292                    (format nil "~%Class description: ~A" it) "")
 293               (aif (slot-value cl 'subobjects)
 294                    (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
 295               (aif (slot-value cl 'print-slots)
 296                    (format nil "~%Print-slots:~{ ~A~}" it) "")
 297               ))))
 298
 299 (defun init-hyperobject-class (cl)
 300   "Initialize a hyperobject class. Calculates all class slots"
 301   (finalize-subobjects cl)
 302   (finalize-views cl)
 303   (finalize-hyperlinks cl)
 304   (finalize-sql cl)
 305   (finalize-documentation cl))
 306
 307
 308 ;;;; *************************************************************************
 309 ;;;;  Metaclass Slot Accessors
 310 ;;;; *************************************************************************
 311
 312 (defun find-slot-by-name (cl name)
 313   (find name (class-slots cl) :key #'slot-definition-name))
 314
 315 (defun hyperobject-class-fmtstr-text (obj)
 316   (slot-value (class-of obj) 'fmtstr-text))
 317
 318 (defun hyperobject-class-fmtstr-html (obj)
 319   (slot-value (class-of obj) 'fmtstr-html))
 320
 321 (defun hyperobject-class-fmtstr-xml (obj)
 322   (slot-value (class-of obj) 'fmtstr-xml))
 323
 324 (defun hyperobject-class-fmtstr-text-labels (obj)
 325   (slot-value (class-of obj) 'fmtstr-text-labels))
 326
 327 (defun hyperobject-class-fmtstr-html-labels (obj)
 328   (slot-value (class-of obj) 'fmtstr-html-labels))
 329
 330 (defun hyperobject-class-fmtstr-xml-labels (obj)
 331   (slot-value (class-of obj) 'fmtstr-xml-labels))
 332
 333 (defun hyperobject-class-value-func (obj)
 334   (slot-value (class-of obj) 'value-func))
 335
 336 (defun hyperobject-class-xmlvalue-func (obj)
 337   (slot-value (class-of obj) 'xmlvalue-func))
 338
 339 (eval-when (:compile-toplevel :load-toplevel :execute)
 340
 341   (defun hyperobject-class-user-name (obj)
 342     (awhen (slot-value (class-of obj) 'user-name)
 343            (if (consp it)
 344                (car it)
 345                it))))
 346
 347 (defun hyperobject-class-subobjects (obj)
 348   (slot-value (class-of obj) 'subobjects))
 349
 350 (defun hyperobject-class-hyperlinks (obj)
 351   (slot-value (class-of obj) 'hyperlinks))
 352
 353 (defun hyperobject-class-fields (obj)
 354   (class-slots (class-of obj)))
 355
 356 (defun hyperobject-class-print-slots (obj)
 357   (slot-value (class-of obj) 'print-slots))
 358
 359 (defun hyperobject-class-fmtstr-html-ref (obj)
 360   (slot-value (class-of obj) 'fmtstr-html-ref))
 361
 362 (defun hyperobject-class-fmtstr-xml-ref (obj)
 363   (slot-value (class-of obj) 'fmtstr-xml-ref))
 364
 365 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 366   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 367
 368 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 369   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 370