;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: hyperobject.lisp
;;;; Purpose: Hyper Object Metaclass
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; This metaclass as functions to classes to allow display
;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
;;;; $Id: mop.lisp,v 1.1 2002/11/29 04:07:52 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(shadowing-import
#+allegro
`(mop::class-slots mop::slot-definition-name mop:finalize-inheritance
mop::standard-direct-slot-definition mop::standard-effective-slot-definition
mop:direct-slot-definition-class mop:compute-effective-slot-definition
excl::compute-effective-slot-definition-initargs)
#+lispworks
`(clos:class-slots clos::slot-definition-name clos:finalize-inheritance
clos::standard-direct-slot-definition clos::standard-effective-slot-definition
clos:direct-slot-definition-class clos:compute-effective-slot-definition
clos::compute-effective-slot-definition-initargs)
#+sbcl
`(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
sb-pcl::standard-direct-slot-definition
sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
sb-pcl::compute-effective-slot-definition-initargs)
#+cmu
`(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class
pcl::slot-definition-name pcl:finalize-inheritance
pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
pcl::validate-superclass pcl:direct-slot-definition-class
pcl:compute-effective-slot-definition
pcl::compute-effective-slot-definition-initargs)
#+scl
`(class-of class-name clos:class-slots clos::standard-class
clos::slot-definition-name clos:finalize-inheritance
clos::standard-direct-slot-definition clos::standard-effective-slot-definition
clos::validate-superclass clos:direct-slot-definition-class
clos:compute-effective-slot-definition
clos::compute-effective-slot-definition-initargs)
:hyperobject))
;; Main class
(defclass hyperobject-class (standard-class)
( ;; slots initialized in defclass
(title :initarg :title :type string :initform nil
:documentation "Print Title for class")
(print-slots :initarg :print-slots :type list :initform nil
:documentation "List of slots to print")
(description :initarg :description :initform nil
:documentation "Class description")
(version :initarg :version :initform nil
:documentation "Version number for class")
;;; The remainder of these fields are calculated one time
;;; in finalize-inheritence.
(subobjects :initform nil :documentation
"List of fields that contain a list of subobjects objects.")
(references :type list :initform nil :documentation
"List of fields that have references")
(class-id :type integer :initform nil :documentation
"Unique ID for the class")
(value-func :initform nil :type function)
(xmlvalue-func :initform nil :type function)
(fmtstr-text :initform nil :type string)
(fmtstr-html :initform nil :type string)
(fmtstr-xml :initform nil :type string)
(fmtstr-text-labels :initform nil :type string)
(fmtstr-html-labels :initform nil :type string)
(fmtstr-xml-labels :initform nil :type string)
(fmtstr-html-ref :initform nil :type string)
(fmtstr-xml-ref :initform nil :type string)
(fmtstr-html-ref-labels :initform nil :type string)
(fmtstr-xml-ref-labels :initform nil :type string)
)
(:documentation "Metaclass for Markup Language classes."))
(defclass subobject ()
((name :type symbol :initform nil :initarg :name :reader name)
(reader :type function :initform nil :initarg :reader :reader reader)))
(defmethod print-object ((obj subobject) (s stream))
(print-unreadable-object (obj s :type t :identity t)
(format s "~S" (name obj))))
(defclass reference ()
((name :type symbol :initform nil :initarg :name :reader name)
(lookup :type function :initform nil :initarg :lookup :reader lookup)
(link-parameters :type list :initform nil :initarg :link-parameters
:reader link-parameters)))
(defmethod print-object ((obj reference) (s stream))
(print-unreadable-object (obj s :type t :identity t)
(format s "~S" (name obj))))
#+(or cmu scl sbcl)
(defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
t)
(defmethod finalize-inheritance :after ((cl hyperobject-class))
(init-hyperobject-class cl))
;; Slot definitions
(defmethod direct-slot-definition-class ((cl hyperobject-class)
#+allegro &rest
iargs)
(find-class 'hyperobject-dsd))
; Slot definitions
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro process-class-option (slot-name &optional required)
#+lispworks
`(defmethod clos:process-a-class-option ((class hyperobject-class)
(name (eql ,slot-name))
value)
(when (and ,required (null value))
(error "hyperobject class slot ~A must have a value" name))
(list name `',value))
#+(or allegro sbcl cmu scl)
(declare (ignore slot-name required))
)
(defmacro process-slot-option (slot-name)
#+lispworks
`(defmethod clos:process-a-slot-option ((class hyperobject-class)
(option (eql ,slot-name))
value
already-processed-other-options
slot)
(list option `',value))
#-lispworks
(declare (ignore slot-name))
)
(defparameter *class-options*
'(:title :print-slots :description :version :sql-name)
"List of class options for hyperobjects.")
(defparameter *slot-options*
'(:print-formatter :subobject :reference :description :unique :sql-name)
"List of slot options that can appear as an initarg")
(defparameter *slot-options-no-initarg*
'(:ho-type)
"List of slot options that do not have an initarg")
(dolist (option *class-options*)
(eval `(process-class-option ,option)))
(dolist (option *slot-options*)
(eval `(process-slot-option ,option)))
(eval
`(defclass hyperobject-dsd (standard-direct-slot-definition)
(,@(mapcar #'(lambda (x)
`(,(intern (symbol-name x))
:initform nil))
*slot-options-no-initarg*)
,@(mapcar #'(lambda (x)
`(,(intern (symbol-name x))
:initarg
,(intern (symbol-name x) (symbol-name :keyword))
:initform nil))
*slot-options*))))
(eval
`(defclass hyperobject-esd (standard-effective-slot-definition)
(,@(mapcar #'(lambda (x)
`(,(intern (symbol-name x))
:initarg
,(intern (symbol-name x) (symbol-name :keyword))
:initform nil))
(append *slot-options* *slot-options-no-initarg*)))))
) ;; eval-when
(defmethod compute-effective-slot-definition :around
((cl hyperobject-class) #+(or allegro lispworks) name dsds)
#+allergo (declare (ignore name))
(let* ((dsd (car dsds))
(ho-type (slot-value dsd 'type)))
(setf (slot-value dsd 'ho-type) ho-type)
(setf (slot-value dsd 'type) (convert-ho-type ho-type))
(let ((ia (compute-effective-slot-definition-initargs
cl #+lispworks name dsds)))
(apply
#'make-instance 'hyperobject-esd
:ho-type ho-type
:print-formatter (slot-value dsd 'print-formatter)
:subobject (slot-value dsd 'subobject)
:reference (slot-value dsd 'reference)
:description (slot-value dsd 'description)
ia)))
)
(defun convert-ho-type (ho-type)
(check-type ho-type symbol)
(case (intern (symbol-name ho-type) (symbol-name :keyword))
(:string
'string)
(:fixnum
'fixnum)
(:boolean
'boolean)
(:integer
'integer)
(:cdata
'string)
(:float
'float)
(:nil
t)
(otherwise
ho-type)))
;;;; Class initialization function
(defun find-slot-by-name (cl name)
(find name (class-slots cl) :key #'slot-definition-name))
(defun process-subobjects (cl)
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
(dolist (slot (class-slots cl))
(when (slot-value slot 'subobject)
(push (make-instance 'subobject :name (slot-definition-name slot)
:reader (if (eq t (slot-value slot 'subobject))
(slot-definition-name slot)
(slot-value slot 'subobject)))
subobjects)))
subobjects)))
(defun process-documentation (cl)
"Calculate class documentation slot"
(awhen (slot-value cl 'title)
(setf (slot-value cl 'title) (car it)))
(awhen (slot-value cl 'description)
(setf (slot-value cl 'description) (car it)))
(let ((*print-circle* nil))
(setf (documentation (class-name cl) 'class)
(format nil "Hyperobject~A~A~A~A"
(aif (slot-value cl 'title)
(format nil ": ~A" it ""))
(aif (slot-value cl 'description)
(format nil "~%Class description: ~A" it) "")
(aif (slot-value cl 'subobjects)
(format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
(aif (slot-value cl 'print-slots)
(format nil "~%Print-slots:~{ ~A~}" it) "")
))))
(defun process-views (cl)
"Calculate all view slots for a hyperobject class"
(let ((fmtstr-text "")
(fmtstr-html "")
(fmtstr-xml "")
(fmtstr-text-labels "")
(fmtstr-html-labels "")
(fmtstr-xml-labels "")
(fmtstr-html-ref "")
(fmtstr-xml-ref "")
(fmtstr-html-ref-labels "")
(fmtstr-xml-ref-labels "")
(first-field t)
(value-func '())
(xmlvalue-func '())
(classname (class-name cl))
(package (symbol-package (class-name cl)))
(references nil))
(declare (ignore classname))
(check-type (slot-value cl 'print-slots) list)
(dolist (slot-name (slot-value cl 'print-slots))
(let ((slot (find-slot-by-name cl slot-name)))
(unless slot
(error "Slot ~A is not found in class ~S" slot-name cl))
(let ((name (slot-definition-name slot))
(namestr (symbol-name (slot-definition-name slot)))
(namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
(type (slot-value slot 'ho-type))
(print-formatter (slot-value slot 'print-formatter))
(value-fmt "~a")
(plain-value-func nil)
html-str xml-str html-label-str xml-label-str)
(when (or (eql type :integer) (eql type :fixnum))
(setq value-fmt "~d"))
(when (eql type :boolean)
(setq value-fmt "~a"))
(if first-field
(setq first-field nil)
(progn
(string-append fmtstr-text " ")
(string-append fmtstr-html " ")
(string-append fmtstr-xml " ")
(string-append fmtstr-text-labels " ")
(string-append fmtstr-html-labels " ")
(string-append fmtstr-xml-labels " ")
(string-append fmtstr-html-ref " ")
(string-append fmtstr-xml-ref " ")
(string-append fmtstr-html-ref-labels " ")
(string-append fmtstr-xml-ref-labels " ")))
(setq html-str (concatenate 'string "" value-fmt ""))
(setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "" namestr-lower ">"))
(setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt ""))
(setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "" namestr-lower ">"))
(string-append fmtstr-text value-fmt)
(string-append fmtstr-html html-str)
(string-append fmtstr-xml xml-str)
(string-append fmtstr-text-labels namestr-lower " " value-fmt)
(string-append fmtstr-html-labels html-label-str)
(string-append fmtstr-xml-labels xml-label-str)
(if (slot-value slot 'reference)
(progn
(string-append fmtstr-html-ref "<~~a>" value-fmt "~~a>")
(string-append fmtstr-xml-ref "<~~a>" value-fmt "~~a>")
(string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "~~a>")
(string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "~~a>")
(push (make-instance 'reference :name name
:lookup (slot-value slot 'reference))
references))
(progn
(string-append fmtstr-html-ref html-str)
(string-append fmtstr-xml-ref xml-str)
(string-append fmtstr-html-ref-labels html-label-str)
(string-append fmtstr-xml-ref-labels xml-label-str)))
(if print-formatter
(setq plain-value-func
(list `(,print-formatter (slot-value x ',(intern namestr package)))))
(setq plain-value-func
(list `(slot-value x ',(intern namestr package)))))
(setq value-func (append value-func plain-value-func))
(if (eql type :cdata)
(setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
(setq xmlvalue-func (append xmlvalue-func plain-value-func)))
)))
(setf (slot-value cl 'references) references)
(if value-func
(setq value-func `(lambda (x) (values ,@value-func)))
(setq value-func `(lambda () (values))))
(setq value-func (compile nil (eval value-func)))
(if xmlvalue-func
(setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
(setq xmlvalue-func `(lambda () (values))))
(setq xmlvalue-func (compile nil (eval xmlvalue-func)))
(setf (slot-value cl 'fmtstr-text) fmtstr-text)
(setf (slot-value cl 'fmtstr-html) fmtstr-html)
(setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
(setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
(setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
(setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
(setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
(setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
(setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
(setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
(setf (slot-value cl 'value-func) value-func)
(setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
(values))
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
(process-subobjects cl)
(process-views cl)
(process-documentation cl))
(defun hyperobject-class-fmtstr-text (obj)
(slot-value (class-of obj) 'fmtstr-text))
(defun hyperobject-class-fmtstr-html (obj)
(slot-value (class-of obj) 'fmtstr-html))
(defun hyperobject-class-fmtstr-xml (obj)
(slot-value (class-of obj) 'fmtstr-xml))
(defun hyperobject-class-fmtstr-text-labels (obj)
(slot-value (class-of obj) 'fmtstr-text-labels))
(defun hyperobject-class-fmtstr-html-labels (obj)
(slot-value (class-of obj) 'fmtstr-html-labels))
(defun hyperobject-class-fmtstr-xml-labels (obj)
(slot-value (class-of obj) 'fmtstr-xml-labels))
(defun hyperobject-class-value-func (obj)
(slot-value (class-of obj) 'value-func))
(defun hyperobject-class-xmlvalue-func (obj)
(slot-value (class-of obj) 'xmlvalue-func))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun hyperobject-class-title (obj)
(awhen (slot-value (class-of obj) 'title)
(if (consp it)
(car it)
it))))
(defun hyperobject-class-subobjects (obj)
(slot-value (class-of obj) 'subobjects))
(defun hyperobject-class-references (obj)
(slot-value (class-of obj) 'references))
(defun hyperobject-class-fields (obj)
(class-slots (class-of obj)))
(defun hyperobject-class-fmtstr-html-ref (obj)
(slot-value (class-of obj) 'fmtstr-html-ref))
(defun hyperobject-class-fmtstr-xml-ref (obj)
(slot-value (class-of obj) 'fmtstr-xml-ref))
(defun hyperobject-class-fmtstr-html-ref-labels (obj)
(slot-value (class-of obj) 'fmtstr-html-ref-labels))
(defun hyperobject-class-fmtstr-xml-ref-labels (obj)
(slot-value (class-of obj) 'fmtstr-xml-ref-labels))