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.13 2002/12/13 22:26:41 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               :accessor user-name
  31               :documentation "User name for class")
  32    (default-print-slots :initarg :default-print-slots :type list :initform nil
  33                         :accessor default-print-slots
  34                         :documentation "Defaults slots for a view")
  35    (description :initarg :description :initform nil
  36                 :accessor description
  37                 :documentation "Class description")
  38    (version :initarg :version :initform nil
  39             :accessor version
  40             :documentation "Version number for class")
  41    (sql-name :initarg :table-name :initform nil)
  42
  43    ;;; The remainder of these fields are calculated one time
  44    ;;; in finalize-inheritence.
  45
  46    (subobjects :initform nil :accessor subobjects
  47                :documentation
  48                "List of fields that contain a list of subobjects objects.")
  49    (hyperlinks :type list :initform nil :accessor hyperlinks
  50                :documentation "List of fields that have hyperlinks")
  51    (direct-rules :type list :initform nil :accessor direct-rules
  52                  :documentation "List of rules to fire on slot changes.")
  53    (class-id :type integer :initform nil
  54              :accessor class-id
  55              :documentation "Unique ID for the class")
  56    (default-view :initform nil :initarg :default-view :accessor default-view
  57                  :documentation "The default view for a class")
  58
  59    ;; SQL commands
  60    (create-table-cmd :initform nil :reader create-table-cmd)
  61    (create-indices-cmds :initform nil :reader create-index-cmds)
  62    (drop-table-cmd :initform nil :reader drop-table-cmd)
  63
  64    (views :type list :initform nil :initarg :views :accessor views
  65           :documentation "List of views")
  66    (rules :type list :initform nil :initarg :rules :accessor rules
  67           :documentation "List of rules")
  68    )
  69   (:documentation "Metaclass for Markup Language classes."))
  70
  71 (defclass subobject ()
  72   ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)
  73    (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
  74    (lookup :type symbol :initform nil :initarg :lookup :reader lookup)
  75    (lookup-keys :type list :initform nil :initarg :lookup-keys
  76                 :reader lookup-keys))
  77   (:documentation "Contains subobject information"))
  78
  79
  80 (defmethod print-object ((obj subobject) (s stream))
  81   (print-unreadable-object (obj s :type t :identity t)
  82     (format s "~S" (name obj))))
  83
  84 (defclass hyperlink ()
  85   ((name :type symbol :initform nil :initarg :name :reader name)
  86    (lookup :type function :initform nil :initarg :lookup :reader lookup)
  87    (link-parameters :type list :initform nil :initarg :link-parameters
  88                     :reader link-parameters)))
  89
  90 (defmethod print-object ((obj hyperlink) (s stream))
  91   (print-unreadable-object (obj s :type t :identity t)
  92     (format s "~S" (name obj))))
  93
  94 #+(or cmu scl sbcl)
  95 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
  96   t)
  97
  98 (defmethod finalize-inheritance :after ((cl hyperobject-class))
  99   (init-hyperobject-class cl)
 100   )
 101
 102 ;; Slot definitions
 103 (defmethod direct-slot-definition-class ((cl hyperobject-class)
 104                                          #+allegro &rest
 105                                                    iargs)
 106   (find-class 'hyperobject-dsd))
 107
 108
 109 ; Slot definitions
 110
 111 (eval-when (:compile-toplevel :load-toplevel :execute)
 112   (defmacro process-class-option (slot-name &optional required)
 113     #+lispworks
 114     `(defmethod clos:process-a-class-option ((class hyperobject-class)
 115                                              (name (eql ,slot-name))
 116                                              value)
 117     (when (and ,required (null value))
 118       (error "hyperobject class slot ~A must have a value" name))
 119     (list name `',value))
 120     #+(or allegro sbcl cmu scl)
 121     (declare (ignore slot-name required))
 122     )
 123
 124   (defmacro process-slot-option (slot-name)
 125     #+lispworks
 126     `(defmethod clos:process-a-slot-option ((class hyperobject-class)
 127                                             (option (eql ,slot-name))
 128                                             value
 129                                           already-processed-other-options
 130                                             slot)
 131        (list option `',value))
 132     #-lispworks
 133     (declare (ignore slot-name))
 134     )
 135
 136   (dolist (option *class-options*)
 137     (eval `(process-class-option ,option)))
 138   (dolist (option *slot-options*)
 139     (eval `(process-slot-option ,option)))
 140
 141   (eval
 142    `(defclass hyperobject-dsd (standard-direct-slot-definition)
 143       (,@(mapcar #'(lambda (x)
 144                      `(,(intern (symbol-name x))
 145                         :initform nil))
 146                  *slot-options-no-initarg*)
 147          ,@(mapcar #'(lambda (x)
 148                        `(,(intern (symbol-name x))
 149                           :initarg
 150                           ,(intern (symbol-name x) (symbol-name :keyword))
 151                           :initform nil
 152                           :accessor
 153                           ,(intern (concatenate 'string
 154                                                 (symbol-name :dsd-)
 155                                                 (symbol-name x)))))
 156                    *slot-options*))))
 157   (eval
 158    `(defclass hyperobject-esd (standard-effective-slot-definition)
 159       (,@(mapcar #'(lambda (x)
 160                      `(,(intern (symbol-name x))
 161                         :initarg
 162                         ,(intern (symbol-name x) (symbol-name :keyword))
 163                         :initform nil
 164                         :accessor
 165                         ,(intern (concatenate 'string
 166                                               (symbol-name :esd-)
 167                                               (symbol-name x)))))
 168                  (append *slot-options* *slot-options-no-initarg*)))))
 169   ) ;; eval-when
 170
 171 (defun intern-in-keyword (obj)
 172   (cond
 173     ((null obj)
 174      nil)
 175     ((eq t obj)
 176      t)
 177     ((atom obj)
 178      (intern (symbol-name obj) (find-package 'keyword)))
 179     ((consp obj)
 180      (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))
 181     (t
 182      obj)))
 183
 184 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
 185                                                       #+(or allegro lispworks) name
 186                                                       dsds)
 187   #+allergo (declare (ignore name))
 188   (let* ((dsd (car dsds))
 189          (ho-type (intern-in-keyword (slot-value dsd 'type)))
 190          (sql-type (ho-type-to-sql-type ho-type))
 191          (length (when (consp ho-type) (cadr ho-type))))
 192   #+allergo (declare (ignore name))
 193     (setf (slot-value dsd 'ho-type) ho-type)
 194     (setf (slot-value dsd 'sql-type) sql-type)
 195     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
 196     (let ((ia (compute-effective-slot-definition-initargs
 197                cl #+lispworks name dsds)))
 198       (apply
 199        #'make-instance 'hyperobject-esd
 200        :ho-type ho-type
 201        :sql-type sql-type
 202        :length length
 203        :print-formatter (slot-value dsd 'print-formatter)
 204        :subobject (slot-value dsd 'subobject)
 205        :hyperlink (slot-value dsd 'hyperlink)
 206        :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
 207        :description (slot-value dsd 'description)
 208        :user-name (slot-value dsd 'user-name)
 209        :index (slot-value dsd 'index)
 210        :value-constraint (slot-value dsd 'value-constraint)
 211        :null-allowed (slot-value dsd 'null-allowed)
 212        ia))))
 213
 214 (defun ho-type-to-lisp-type (ho-type)
 215   (when (consp ho-type)
 216     (setq ho-type (car ho-type)))
 217   (check-type ho-type symbol)
 218   (case ho-type
 219     ((or :string :cdata :varchar :char)
 220      'string)
 221     (:character
 222      'character)
 223     (:fixnum
 224      'fixnum)
 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 (defun ho-type-to-sql-type (ho-type)
 239   (when (consp ho-type)
 240     (setq ho-type (car ho-type)))
 241   (check-type ho-type symbol)
 242   (case ho-type
 243     ((or :string :cdata)
 244      'string)
 245     (:fixnum
 246      'integer)
 247     (:boolean
 248      'boolean)
 249     (:integer
 250      'integer)
 251     ((or :float :single-float)
 252      'single-float)
 253     (:double-float
 254      'double-float)
 255     (nil
 256      t)
 257     (otherwise
 258      ho-type)))
 259
 260
 261 ;;;; Class initialization function
 262
 263 ;; defines a slot-unbound method for class and slot-name, fills
 264 ;; the slot by calling reader function with the slot values of
 265 ;; the instance's reader-keys
 266 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
 267   (let* ((the-slot-name (gensym))
 268          (the-class (gensym))
 269          (the-instance (gensym))
 270          (keys '()))
 271     (dolist (key reader-keys)
 272       (push (list 'slot-value the-instance (list 'quote key)) keys))
 273     (setq keys (nreverse keys))
 274     `(defmethod slot-unbound (,the-class (,the-instance ,class)
 275                                          (,the-slot-name (eql ',slot-name)))
 276        (declare (ignore ,the-class))
 277        (setf (slot-value ,the-instance ,the-slot-name)
 278            (,reader ,@keys)))))
 279
 280 (defun finalize-subobjects (cl)
 281   "Process class subobjects slot"
 282   (setf (subobjects cl)
 283     (let ((subobjects '()))
 284       (dolist (slot (class-slots cl))
 285         (let-when (subobj-def (esd-subobject slot))
 286           (let ((subobject (make-instance 'subobject
 287                                           :name-class (class-name cl)
 288                                           :name-slot (slot-definition-name slot)
 289                                           :lookup (if (atom subobj-def)
 290                                                       subobj-def
 291                                                       (car subobj-def))
 292                                           :lookup-keys (if (atom subobj-def)
 293                                                            nil
 294                                                            (cdr subobj-def)))))
 295             (unless (eq (lookup subobject) t)
 296               (eval `(def-lazy-reader ,(name-class subobject)
 297                          ,(name-slot subobject) ,(lookup subobject)
 298                          ,@(lookup-keys subobject))))
 299             (push subobject subobjects))))
 300       subobjects)))
 301
 302 (defun finalize-documentation (cl)
 303   "Calculate class documentation slot"
 304   (awhen (slot-value cl 'user-name)
 305          (setf (slot-value cl 'user-name)
 306                (etypecase (slot-value cl 'user-name)
 307                    (cons (car it))
 308                    ((or string symbol) it))))
 309   (awhen (slot-value cl 'description)
 310          (setf (slot-value cl 'description)
 311                (etypecase (slot-value cl 'description)
 312                    (cons (car it))
 313                    ((or string symbol) it))))
 314
 315   (let ((*print-circle* nil))
 316     (setf (documentation (class-name cl) 'class)
 317       (format nil "Hyperobject~A~A~A~A"
 318               (aif (user-name cl)
 319                    (format nil ": ~A" it ""))
 320               (aif (description cl)
 321                    (format nil "~%Class description: ~A" it) "")
 322               (aif (subobjects cl)
 323                    (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
 324               (aif (default-print-slots cl)
 325                    (format nil "~%Default print slots:~{ ~A~}" it) "")
 326               ))))
 327
 328 (defun finalize-hyperlinks (cl)
 329   (let ((hyperlinks '()))
 330     (dolist (esd (class-slots cl))
 331       (awhen (slot-value esd 'hyperlink)
 332         (push
 333          (make-instance 'hyperlink
 334                         :name (slot-definition-name esd)
 335                         :lookup it
 336                         :link-parameters (slot-value esd 'hyperlink-parameters))
 337          hyperlinks)))
 338     (setf (slot-value cl 'hyperlinks) hyperlinks)))
 339
 340 (defun init-hyperobject-class (cl)
 341   "Initialize a hyperobject class. Calculates all class slots"
 342   (finalize-subobjects cl)
 343   (finalize-views cl)
 344   (finalize-hyperlinks cl)
 345   (finalize-sql cl)
 346   (finalize-rules cl)
 347   (finalize-documentation cl))
 348
 349
 350 ;;;; *************************************************************************
 351 ;;;;  Metaclass Slot Accessors
 352 ;;;; *************************************************************************
 353
 354 (defun find-slot-by-name (cl name)
 355   (find name (class-slots cl) :key #'slot-definition-name))
 356
 357 (defun hyperobject-class-user-name (obj)
 358   (awhen (user-name (class-of obj))
 359          (if (consp it)
 360              (car it)
 361              it)))
 362
 363 (defun hyperobject-class-subobjects (obj)
 364   (subobjects (class-of obj)))
 365
 366 (defun hyperobject-class-hyperlinks (obj)
 367   (hyperlinks (class-of obj)))
 368
 369 (defun hyperobject-class-fields (obj)
 370   (class-slots (class-of obj)))
 371
 372 ;;; Slot accessor and class rules
 373
 374 (defclass rule ()
 375   ((dependants :initarg dependants :initform nil :accessor dependants)
 376    (volatile :initarg modifieds :initform nil :accessor modifieds)
 377    (source-code :initarg source-code :initform nil :accessor source-code)
 378    (function :initform nil :accessor function)))
 379
 380 (defun compile-rule (source-code cl)
 381   )
 382
 383 (defun finalize-rules (cl)
 384   (let* ((direct-rules (direct-rules cl))
 385          (rule-vector (make-vector (length direct-rules) :fill-pointer nil
 386                                    :adjustable nil)))
 387     (dotimes (i (length direct-rules))
 388       (destructuring-bind (name (&key dependants volatile) &rest source-code)
 389           (nth i direct-rules)
 390         (setf (aref rule-vector i) (make-instance 'rule
 391                                                   :name name
 392                                                   :dependants depedenants
 393                                                   :volatile volatile
 394                                                   :source-code source-code
 395                                                   :function (compile-rule source-code cl)))))
 396     (setf (rules cl) rule-vector)))
 397
 398 (defun fire-class-rules (cl obj)
 399   "Fire all class rules. Called after a slot is modified."
 400   (dolist (rule (direct-rules cl))
 401     (cmsg "firing rule: ~a" rule)))
 402
 403
 404 (defmethod (setf slot-value-using-class)
 405     :around (new-value (cl hyperobject-class) obj
 406              (slot standard-effective-slot-definition))
 407   (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value)
 408   (let ((func (esd-value-constraint slot)))
 409     (cond
 410      ((and func (not (funcall func new-value obj)))
 411       (warn "Rejected change to value of slot ~a of object ~a"
 412             (slot-definition-name slot) obj)
 413       (slot-value obj (slot-definition-name slot)))
 414      (t
 415       (call-next-method)
 416       (fire-class-rules cl obj)
 417       new-value))))
 418
 419 (defmethod slot-value-using-class :around ((cl hyperobject-class) obj
 420                                            (slot standard-effective-slot-definition))
 421   (let ((value (call-next-method)))
 422     (cmsg-c :verbose "slot value: class: ~s, obj: ~s, slot: ~s" cl (class-of obj) slot)
 423     value))