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