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