1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Metaobject Protocol Interface
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
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.
14 ;;;; $Id: mop.lisp,v 1.71 2003/05/14 05:36:22 kevin Exp $
16 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
17 ;;;; *************************************************************************
19 (in-package :hyperobject)
21 (eval-when (:compile-toplevel :execute)
22 (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
26 (defclass hyperobject-class (standard-class)
27 ( ;; slots initialized in defclass
28 (user-name :initarg :user-name :type string :initform nil
30 :documentation "User name for class")
31 (user-name-plural :initarg :user-name-plural :type string :initform nil
32 :accessor user-name-plural
33 :documentation "Plural user name for class")
34 (default-print-slots :initarg :default-print-slots :type list :initform nil
35 :accessor default-print-slots
36 :documentation "Defaults slots for a view")
37 (description :initarg :description :initform nil
39 :documentation "Class description")
40 (version :initarg :version :initform nil
42 :documentation "Version number for class")
43 (sql-name :initarg :sql-name :initform nil)
45 ;;; The remainder of these fields are calculated one time
46 ;;; in finalize-inheritence.
48 (subobjects :initform nil :accessor subobjects
50 "List of fields that contain a list of subobjects objects.")
51 (hyperlinks :type list :initform nil :accessor hyperlinks
52 :documentation "List of fields that have hyperlinks")
53 (direct-rules :type list :initform nil :initarg :direct-rules
54 :accessor direct-rules
55 :documentation "List of rules to fire on slot changes.")
56 (class-id :type integer :initform nil
58 :documentation "Unique ID for the class")
59 (default-view :initform nil :initarg :default-view :accessor default-view
60 :documentation "The default view for a class")
63 (create-table-cmd :initform nil :reader create-table-cmd)
64 (create-indices-cmds :initform nil :reader create-index-cmds)
65 (drop-table-cmd :initform nil :reader drop-table-cmd)
67 (views :type list :initform nil :initarg :views :accessor views
68 :documentation "List of views")
69 (rules :type list :initform nil :initarg :rules :accessor rules
70 :documentation "List of rules")
72 (:documentation "Metaclass for Markup Language classes."))
74 (defclass subobject ()
75 ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)
76 (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
77 (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup)
78 (lookup-keys :type list :initform nil :initarg :lookup-keys
80 (:documentation "Contains subobject information"))
83 (defmethod print-object ((obj subobject) (s stream))
84 (print-unreadable-object (obj s :type t :identity t)
85 (format s "~S" (name obj))))
87 (defclass hyperlink ()
88 ((name :type symbol :initform nil :initarg :name :reader name)
90 ;; The type specifier seems to break sbcl
91 :type (or function symbol)
93 :initform nil :initarg :lookup :reader lookup)
94 (link-parameters :type list :initform nil :initarg :link-parameters
95 :reader link-parameters)))
97 (defmethod print-object ((obj hyperlink) (s stream))
98 (print-unreadable-object (obj s :type t :identity t)
99 (format s "~S" (name obj))))
102 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
105 (defmethod finalize-inheritance :after ((cl hyperobject-class))
106 (init-hyperobject-class cl)
109 (eval-when (:compile-toplevel :load-toplevel :execute)
110 (when (>= (length (generic-function-lambda-list
111 (ensure-generic-function
112 'compute-effective-slot-definition)))
114 (pushnew :ho-normal-cesd cl:*features*))
116 (when (>= (length (generic-function-lambda-list
117 (ensure-generic-function
118 'direct-slot-definition-class)))
120 (pushnew :ho-normal-dsdc cl:*features*))
122 (when (>= (length (generic-function-lambda-list
123 (ensure-generic-function
124 'effective-slot-definition-class)))
126 (pushnew :ho-normal-esdc cl:*features*)))
129 (defmethod direct-slot-definition-class ((cl hyperobject-class)
130 #+ho-normal-dsdc &rest iargs)
131 (find-class 'hyperobject-dsd))
133 (defmethod effective-slot-definition-class ((cl hyperobject-class)
134 #+ho-normal-esdc &rest iargs)
135 (find-class 'hyperobject-esd))
140 (eval-when (:compile-toplevel :load-toplevel :execute)
141 (defmacro process-class-option (slot-name &optional required)
143 `(defmethod clos:process-a-class-option ((class hyperobject-class)
144 (name (eql ,slot-name))
146 (when (and ,required (null value))
147 (error "hyperobject class slot ~A must have a value" name))
148 (list name `',value))
149 #+(or allegro sbcl cmu scl)
150 (declare (ignore slot-name required))
153 (defmacro process-slot-option (slot-name)
155 `(defmethod clos:process-a-slot-option ((class hyperobject-class)
156 (option (eql ,slot-name))
158 already-processed-options
160 (list* option `',value already-processed-options))
162 (declare (ignore slot-name))
165 (dolist (option *class-options*)
166 (eval `(process-class-option ,option)))
167 (dolist (option *slot-options*)
168 (eval `(process-slot-option ,option)))
171 `(defclass hyperobject-dsd (standard-direct-slot-definition)
172 (,@(mapcar #'(lambda (x)
173 `(,(intern (symbol-name x))
175 *slot-options-no-initarg*)
176 ,@(mapcar #'(lambda (x)
177 `(,(intern (symbol-name x))
179 ,(intern (symbol-name x) (symbol-name :keyword))
182 ,(intern (concatenate 'string
187 `(defclass hyperobject-esd (standard-effective-slot-definition)
188 (,@(mapcar #'(lambda (x)
189 `(,(intern (symbol-name x))
191 ,(intern (symbol-name x) (symbol-name :keyword))
194 ,(intern (concatenate 'string
197 (append *slot-options* *slot-options-no-initarg*)))))
200 (defun intern-in-keyword (obj)
207 (intern (symbol-name obj) (find-package 'keyword)))
209 (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))
213 (defun canonicalize-value-type (vt)
218 (cons (ensure-keyword (car vt)) (cdr vt)))
223 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds)
224 #+allegro (declare (ignore name))
225 (let* ((dsd (car dsds))
226 (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
227 (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)
228 (setf (slot-value dsd 'sql-type) sql-type)
229 (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type))
230 (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds)))
232 #'make-instance 'hyperobject-esd
233 :value-type value-type
236 :print-formatter (slot-value dsd 'print-formatter)
237 :subobject (slot-value dsd 'subobject)
238 :hyperlink (slot-value dsd 'hyperlink)
239 :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
240 :description (slot-value dsd 'description)
241 :user-name (slot-value dsd 'user-name)
242 :user-name-plural (slot-value dsd 'user-name-plural)
243 :index (slot-value dsd 'index)
244 :value-constraint (slot-value dsd 'value-constraint)
245 :null-allowed (slot-value dsd 'null-allowed)
248 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds)
249 #+ho-normal-cesd (declare (ignore name))
250 (let* ((esd (call-next-method))
252 (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
253 (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)
254 (setf (slot-value esd 'sql-type) sql-type)
255 (setf (slot-value esd 'length) length)
256 (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))
257 (setf (slot-value esd 'value-type) value-type)
258 (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters
259 description value-constraint index null-allowed user-name))
260 (setf (slot-value esd name) (slot-value dsd name)))
265 (setq cl:*features* (delete :ho-normal-cesd cl:*features*))
267 (setq cl:*features* (delete :ho-normal-dsdc cl:*features*))
269 (setq cl:*features* (delete :ho-normal-esdc cl:*features*))
271 (defun lisp-type-is-a-string (type)
272 (or (eq type 'string)
273 (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))
275 (defun value-type-to-lisp-type (value-type)
276 (case (if (atom value-type)
279 ((:string :cdata :varchar :char)
282 '(or null character))
289 ((:float :single-float)
290 '(or null single-float))
292 '(or null double-float))
296 (defun value-type-to-sql-type (value-type)
297 "Return two values, the sql type and field length."
298 (let ((type (if (atom value-type)
301 (length (when (consp value-type)
311 ((:float :single-float)
319 ;;;; Class initialization function
321 ;; defines a slot-unbound method for class and slot-name, fills
322 ;; the slot by calling reader function with the slot values of
323 ;; the instance's reader-keys
324 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
325 (let* ((the-slot-name (gensym))
327 (the-instance (gensym))
329 (dolist (key reader-keys)
330 (push (list 'slot-value the-instance (list 'quote key)) keys))
331 (setq keys (nreverse keys))
332 `(defmethod slot-unbound (,the-class (,the-instance ,class)
333 (,the-slot-name (eql ',slot-name)))
334 (declare (ignore ,the-class))
335 (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))
339 (defun intern-eql-specializer (slot)
342 #+(or sbcl cmu lispworks)
343 (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)
345 (gf (ensure-generic-function 'slot-unbound)))
346 (dolist (key reader-keys)
347 (push (list 'slot-value 'the-instance (list 'quote key)) keys))
348 (setq keys (nreverse keys))
349 (multiple-value-bind (method-lambda init-args-values)
352 (class-prototype (generic-function-method-class gf))
354 `(lambda (the-class the-instance the-slot-name)
355 (declare (ignore the-class))
356 (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))
358 '(the-class the-instance the-slot-name)
362 `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))
366 #'make-instance (generic-function-method-class gf)
367 ':specializers (list (class-of (find-class class-name))
368 (find-class class-name)
369 (intern-eql-specializer slot-name))
370 ':lambda-list '(the-class the-instance the-slot-name)
371 ':function (compile nil method-lambda)
372 init-args-values)))))
374 (defun finalize-subobjects (cl)
375 "Process class subobjects slot"
376 (setf (subobjects cl)
377 (let ((subobjects '()))
378 (dolist (slot (class-slots cl))
380 (subobj-def (esd-subobject slot))
382 (make-instance 'subobject
383 :name-class (class-name cl)
384 :name-slot (slot-definition-name slot)
385 :lookup (if (atom subobj-def)
388 :lookup-keys (if (atom subobj-def)
391 (unless (eq (lookup subobject) t)
392 #-(or sbcl cmu lispworks)
394 `(hyperobject::def-lazy-reader ,(name-class subobject)
395 ,(name-slot subobject) ,(lookup subobject)
396 ,@(lookup-keys subobject)))
397 #+(or sbcl cmu lispworks)
398 (apply #'ensure-lazy-reader
399 (name-class subobject) (name-slot subobject)
400 (lookup subobject) (lookup-keys subobject)))
401 (push subobject subobjects))))
402 ;; sbcl/cmu reverse class-slots compared to the defclass form
403 ;; so re-reverse on cmu/sbcl
404 #+(or cmu sbcl) subobjects
405 #-(or cmu sbcl) (nreverse subobjects)
409 (defun finalize-class-slots (cl)
410 "Make sure all class slots have an expected value"
411 (unless (user-name cl)
412 (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))
414 (setf (user-name-plural cl)
415 (if (and (consp (user-name cl)) (cadr (user-name cl)))
416 (cadr (user-name cl))
417 (format nil "~A~P" (if (consp (user-name cl))
422 (dolist (name '(user-name description))
423 (awhen (slot-value cl name)
424 (setf (slot-value cl name)
425 (etypecase (slot-value cl name)
427 ((or string symbol) it))))))
429 (defun finalize-documentation (cl)
430 "Calculate class documentation slot"
431 (let ((*print-circle* nil))
432 (setf (documentation (class-name cl) 'class)
433 (format nil "Hyperobject~A~A~A~A"
435 (format nil ": ~A" it ""))
436 (aif (description cl)
437 (format nil "~%Class description: ~A" it) "")
439 (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
440 (aif (default-print-slots cl)
441 (format nil "~%Default print slots:~{ ~A~}" it) "")
444 (defun finalize-hyperlinks (cl)
445 (let ((hyperlinks '()))
446 (dolist (esd (class-slots cl))
447 (awhen (slot-value esd 'hyperlink)
449 (make-instance 'hyperlink
450 :name (slot-definition-name esd)
452 :link-parameters (slot-value esd 'hyperlink-parameters))
454 ;; cmu/sbcl reverse class-slots compared to the defclass form
455 ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu
456 #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks))
457 (setf (slot-value cl 'hyperlinks) hyperlinks)))
459 (defun init-hyperobject-class (cl)
460 "Initialize a hyperobject class. Calculates all class slots"
461 (finalize-subobjects cl)
463 (finalize-hyperlinks cl)
466 (finalize-class-slots cl)
467 (finalize-documentation cl))
470 ;;;; *************************************************************************
471 ;;;; Metaclass Slot Accessors
472 ;;;; *************************************************************************
474 (defun find-slot-by-name (cl name)
475 (find name (class-slots cl) :key #'slot-definition-name))
477 (defun hyperobject-class-user-name (obj)
478 (user-name (class-of obj)))
480 (defun hyperobject-class-user-name-plural (obj)
481 (user-name-plural (class-of obj)))
483 (defun hyperobject-class-subobjects (obj)
484 (subobjects (class-of obj)))
486 (defun hyperobject-class-hyperlinks (obj)
487 (hyperlinks (class-of obj)))
489 (defun hyperobject-class-slots (obj)
490 ;; cmucl/sbcl reverse class-slots
491 #+(or cmu sbcl) (reverse (class-slots (class-of obj)))
492 #-(or cmu sbcl) (class-slots (class-of obj)))