X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject.lisp;h=95d9c0b65e3467d777fb4bfc64d3160695cd0bb4;hb=63b552ae64bb098d42c4f23c2850a03ff707f12a;hp=926fde9b7d17847a96f057a9ad0c3a74818ca156;hpb=ec0e06f1c59ea3aa00090010a6d53ea3f712ed1d;p=hyperobject.git diff --git a/hyperobject.lisp b/hyperobject.lisp index 926fde9..95d9c0b 100644 --- a/hyperobject.lisp +++ b/hyperobject.lisp @@ -1,17 +1,15 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: HYPEROBJECT -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject.lisp -;;;; Purpose: Hyper Object Metaclass +;;;; Purpose: Hyper Object (Plain - no Metaclass) ;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 +;;;; Date Started: Nov 2002 ;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. +;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. ;;;; -;;;; $Id: hyperobject.lisp,v 1.4 2002/11/04 19:19:04 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.5 2002/11/22 10:49:24 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -24,130 +22,186 @@ (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) -;; Utilities +;; Main class + +(defclass hyperobject () + ()) -(defun portable-class-of (obj) - #-(or cmu sbcl) (class-of obj) - #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) +(defclass hyperobject-meta () + ((fields :initform nil :type list) + (subobjects :initform nil :type list) + (references :initform nil :type list) + (value-func :initform nil :type function) + (xml-value-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 "Class holding meta information for hyperobjects")) -(defun portable-class-name (obj) - #-(or cmu sbcl) (class-name obj) - #+sbcl (sb-pcl:class-name obj) - #+cmu (pcl:class-name obj)) +(defclass field () + ((name :type symbol :initform nil :initarg :name :reader name) + (format-func :initform nil :initarg :format-func :reader format-func) + (cl-type :initform nil :reader cl-type) + (ho-type :initform nil :reader ho-type) + (subobject :initform nil :reader subobject) + (reference :initform nil :reader reference) + )) -;; Main class -(defclass hyperobject-class (#-(or cmu sbcl) standard-class - #+cmu pcl::standard-class - #+sbcl sb-pcl::standard-class) - ((title :initarg :title :type string :reader ml-std-title - :documentation -"Print Title for class") - (fields :initarg :fields :reader ml-std-fields - :documentation -"List of field lists for printing. Format is - ((fieldname type optional-formatter) ... )") - (subobjects-lists - :initarg :subobjects-lists :reader ml-std-subobjects-lists - :documentation -"List of fields that contain a list of subobjects objects.") - (ref-fields - :initarg :ref-fields :type list :reader ml-std-ref-field - :documentation - "List of fields that can be referred to by browsers. -Format is ((field-name field-lookup-func other-link-params) ...)") +(defmethod print-object ((obj field) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +(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)))) - ;;; The remainder of these fields are calculated one time - ;;; in finalize-inheritence. - (value-func :initform nil :type function :reader ml-std-value-func) - (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func) - (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text) - (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html) - (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml) - (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels) - (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels) - (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels) - (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref) - (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref) - (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels) - (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels) - ) - (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) - (:documentation "Metaclass for Markup Language classes.")) - - -#+cmu -(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+scl -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+sbcl -(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+cmu -(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class)) - t) - -#+scl -(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class)) - t) - -#+sbcl -(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class)) - t) - -#+allegro -(defmethod mop:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+lispworks -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :title)) - value) - (unless value - (error "hyperobject-class title must have a value")) - (if (null (cdr value)) - (list name (car value)) - (list name `',value))) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :fields)) - value) - (unless value - (error "hyperobject-class fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :ref-fields)) - value) - (unless value - (error "hyperobject-class ref-fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :subobjects-lists)) - value) - (unless value - (error "hyperobject-class subobjects-lists must have a value")) - (list name `',value)) +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(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) + (otherwise + ho-type))) + +(defun process-hyper-fields (raw-fields meta) + (let* ((fields '()) + (references '()) + (subobjects '()) + (processed-fields + (loop for field in raw-fields + collecting + (destructuring-bind + (name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + type reader writer accessor initform format-func initarg + reference subobject + ;; list ends + &allow-other-keys) field + (let ((other-args (remove-keys + '(type reader writer accessor initform format-func + initarg reference subobject) + rest)) + (field-obj (make-instance 'field :name name)) + (kv nil)) + (declare (ignore other-args)) + (push field-obj fields) + (loop for (k v) in `((:type ,type) (:reader ,reader) (:writer ,writer) + (:accessor ,accessor) (:initform ,initform) + (:format-func ,format-func) (:initarg ,initarg) + (:subobject ,subobject) (:reference ,reference)) + do + (case k + (:initarg + (push (list :initarg + (if v + v + (intern (symbol-name name) + (symbol-name :keyword)))) + kv)) + (:accessor + (when v + (push (list :accessor v) kv))) + (:format-func + (when v + (setf (slot-value field-obj 'format-func) v))) + (:writer + (when v + (push (list :writer v) kv))) + (:reader + (if v + (push (list :reader v) kv) + (push (list :reader name) kv))) + (:type + (when v + (setf (slot-value field-obj 'ho-type) v) + (setf (slot-value field-obj 'cl-type) (convert-ho-type v)) + (push (list :type (cl-type field-obj)) kv))) + (:subobject + (when v + (let ((subobj (make-instance + 'subobject :name name + :reader + (if (eq v t) + name + v)))) + (setf (slot-value field-obj 'subobject) subobj) + (push subobj subobjects)))) + (:reference + (when v + (let ((ref (make-instance 'reference :name name :lookup v))) + (setf (slot-value field-obj 'reference) ref) + (push ref references)))) + )) + (append + (list name) + (loop for (k v) in kv + collecting k + collecting v))))))) + (setf (slot-value meta 'fields) (nreverse fields)) + (setf (slot-value meta 'references) (nreverse references)) + (setf (slot-value meta 'subobjects) (nreverse subobjects)) + processed-fields)) + + +(defun process-title (name meta) + (let ((title (cadr (assoc :title meta)))) + (if title + (if (symbolp title) + (symbol-name title) + title) + (symbol-name name)))) + +(defun process-documentation (meta) + (let ((doc (cadr (assoc :title meta)))) + (if (and doc (symbolp doc)) + (symbol-name doc) + doc))) + +(defun fmt-comma-integer (i) + (format nil "~:d" i)) ;;;; Class initialization function - -(defun init-hyperobject-class (cl) +(defun init-hyperobject-class (name meta) (let ((fmtstr-text "") (fmtstr-html "") (fmtstr-xml "") @@ -160,166 +214,166 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (fmtstr-xml-ref-labels "") (first-field t) (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (portable-class-name cl))) - (ref-fields (slot-value cl 'ref-fields))) - (declare (ignore classname)) - (dolist (f (slot-value cl 'fields)) - (let ((name (car f)) - (namestr (symbol-name (car f))) - (namestr-lower (string-downcase (symbol-name (car f)))) - (type (cadr f)) - (formatter (caddr f)) - (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 :commainteger) - (setq value-fmt "~:d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) + (xml-value-func '()) + (package (symbol-package name))) + (dolist (field (slot-value meta 'fields)) + (declare (ignore rest)) + (let* ((name (name field)) + (format-func (format-func field)) + (type (ho-type field)) + (reference (reference field)) + (namestr (symbol-name name)) + (namestr-lower (string-downcase (symbol-name name))) + (value-fmt "~a") + (plain-value-func nil) + html-str xml-str html-label-str xml-label-str) + (unless (subobject field) + (when (or (eql type :integer) (eql type :fixnum)) + (setq value-fmt "~d")) - (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 "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (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 (find name ref-fields :key #'car) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) - (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 formatter - (setq plain-value-func - (list `(,formatter (,(intern namestr package) x)))) - (setq plain-value-func - (list `(,(intern namestr package) x)))) - (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))) - )) - + (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 "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (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 reference + (progn + (string-append fmtstr-html-ref "<~~a>" value-fmt "") + (string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) + (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 format-func + (setq plain-value-func + (list `(,format-func (,(intern namestr package) x)))) + (setq plain-value-func + (list `(,(intern namestr package) x)))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xml-value-func (append xml-value-func (list `(xml-cdata ,@plain-value-func)))) + (setq xml-value-func (append xml-value-func plain-value-func))) + ))) + (if value-func (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) + (setq value-func `(lambda () (values)))) - (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)) + (if xml-value-func + (setq xml-value-func `(lambda (x) (values ,@xml-value-func))) + (setq xml-value-func `(lambda () (values)))) + + (setf (slot-value meta 'fmtstr-text) fmtstr-text) + (setf (slot-value meta 'fmtstr-html) fmtstr-html) + (setf (slot-value meta 'fmtstr-xml) fmtstr-xml) + (setf (slot-value meta 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value meta 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value meta 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value meta 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value meta 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value meta 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value meta 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value meta 'value-func) value-func) + (setf (slot-value meta 'xml-value-func) xml-value-func)) (values)) - -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (portable-class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (portable-class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (portable-class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (portable-class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun hyperobject-class-title (obj) - (awhen (slot-value (portable-class-of obj) 'title) - (if (consp it) - (car it) - it)))) - -(defun hyperobject-class-subobjects-lists (obj) - (slot-value (portable-class-of obj) 'subobjects-lists)) - -(defun hyperobject-class-ref-fields (obj) - (slot-value (portable-class-of obj) 'ref-fields)) - -(defun hyperobject-class-fields (obj) - (slot-value (portable-class-of obj) 'fields)) - -(defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels)) - -;;; Class name functions - -(defgeneric hyperobject-class-stdname (x)) -(defmethod hyperobject-class-stdname ((name string)) - (string-downcase (subseq name 1))) - -(defmethod hyperobject-class-stdname ((cl standard-object)) - (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1))) +(defgeneric ho-title (obj) ) +(defgeneric ho-name (obj) ) +(defgeneric ho-value-func (obj) ) +(defgeneric ho-xml-value-func (obj) ) +(defgeneric ho-fmtstr-text (obj) ) +(defgeneric ho-fmtstr-html (obj) ) +(defgeneric ho-fmtstr-xml (obj) ) +(defgeneric ho-fmtstr-text-labels (obj) ) +(defgeneric ho-fmtstr-html-labels (obj) ) +(defgeneric ho-fmtstr-xml-labels (obj) ) +(defgeneric ho-fmtstr-html-ref (obj) ) +(defgeneric ho-fmtstr-xml-ref (obj) ) +(defgeneric ho-fmtstr-html-ref-labels (obj) ) +(defgeneric ho-fmtstr-xml-ref-labels (obj) ) +(defgeneric ho-fields (obj) ) +(defgeneric ho-references (obj) ) +(defgeneric ho-subobjects (obj) ) +(defmacro define-hyperobject (name parents fields &rest meta-fields) + (let* ((meta (make-instance 'hyperobject-meta)) + (cl-fields (process-hyper-fields fields meta)) + (title (process-title name meta-fields)) + (documentation (process-documentation meta-fields)) + (value-func (gensym)) + (xml-value-func (gensym))) + (init-hyperobject-class name meta) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ,name ,(append parents (list 'hyperobject)) ,cl-fields + ,@(and documentation (list (list :documentation documentation))))) + (let ((,value-func (compile nil (eval (slot-value ,meta 'value-func)))) + (,xml-value-func (compile nil (eval (slot-value ,meta 'xml-value-func))))) + (defmethod ho-title ((obj ,name)) + ,title) + (defmethod ho-name ((obj ,name)) + ,(string-downcase (symbol-name name))) + (defmethod ho-fields ((obj ,name)) + ',(slot-value meta 'fields)) + (defmethod ho-references ((obj ,name)) + ',(slot-value meta 'references)) + (defmethod ho-subobjects ((obj ,name)) + ',(slot-value meta 'subobjects)) + (defmethod ho-value-func ((obj ,name)) + ,value-func) + (defmethod ho-xml-value-func ((obj ,name)) + ,xml-value-func) + (defmethod ho-fmtstr-text ((obj ,name)) + ,(slot-value meta 'fmtstr-text)) + (defmethod ho-fmtstr-html ((obj ,name)) + ,(slot-value meta 'fmtstr-html)) + (defmethod ho-fmtstr-xml ((obj ,name)) + ,(slot-value meta 'fmtstr-xml)) + (defmethod ho-fmtstr-text-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-text-labels)) + (defmethod ho-fmtstr-html-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-html-labels)) + (defmethod ho-fmtstr-xml-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-labels)) + (defmethod ho-fmtstr-html-ref ((obj ,name)) + ,(slot-value meta 'fmtstr-html-ref)) + (defmethod ho-fmtstr-xml-ref ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-ref)) + (defmethod ho-fmtstr-html-ref-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-html-ref-labels)) + (defmethod ho-fmtstr-xml-ref-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-ref-labels)) + )))) + ;;;; Generic Print functions (defparameter *default-textformat* nil) @@ -358,7 +412,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:null *default-nullformat*) (otherwise *default-textformat*))) -;;;; Output format classes for print hyperobject-classes +;;;; Output format classes for print hoes (defclass dataformat () ((file-start-str :type string :initarg :file-start-str :reader file-start-str) @@ -396,7 +450,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ()) (defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) + (values (ho-title obj) nitems)) (defclass textformat (dataformat) () @@ -404,17 +458,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :list-start-value-func #'text-list-start-value-func :list-start-indent t :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-text - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels + :obj-data-fmtstr #'ho-fmtstr-text + :obj-data-fmtstr-labels #'ho-fmtstr-text-labels :obj-data-end-fmtstr "~%" - :obj-data-value-func #'hyperobject-class-value-func)) + :obj-data-value-func #'ho-value-func)) -(defun class-name-of (obj) - (string-downcase (portable-class-name (portable-class-of obj)))) - (defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) + (values (ho-title x) nitems (ho-name x))) (defclass htmlformat (textformat) () @@ -433,9 +484,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-end-fmtstr "~%" :obj-end-value-func #'identity :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels - :obj-data-value-func #'hyperobject-class-value-func)) + :obj-data-fmtstr #'ho-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-fmtstr-html-labels + :obj-data-value-func #'ho-value-func)) (defclass xhtmlformat (textformat) () @@ -454,16 +505,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-end-fmtstr "~%" :obj-end-value-func #'identity :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels - :obj-data-value-func #'hyperobject-class-xmlvalue-func)) + :obj-data-fmtstr #'ho-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-fmtstr-html-labels + :obj-data-value-func #'ho-xml-value-func)) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (class-name-of x))) + (format nil "~alist" (ho-name x))) (defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems)) + (values (format nil "~alist" (ho-name x)) (ho-title x) nitems)) (defclass xmlformat (textformat) () @@ -475,15 +526,15 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :list-end-fmtstr "~%" :list-end-value-func #'xmlformat-list-end-value-func :obj-start-fmtstr "<~a>" - :obj-start-value-func #'class-name-of + :obj-start-value-func #'ho-name :obj-start-indent t :obj-end-fmtstr "~%" - :obj-end-value-func #'class-name-of + :obj-end-value-func #'ho-name :obj-end-indent nil :obj-data-indent nil - :obj-data-fmtstr #'hyperobject-class-fmtstr-xml - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels - :obj-data-value-func #'hyperobject-class-xmlvalue-func)) + :obj-data-fmtstr #'ho-fmtstr-xml + :obj-data-fmtstr-labels #'ho-fmtstr-xml-labels + :obj-data-value-func #'ho-xml-value-func)) (defclass link-ref () ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) @@ -500,24 +551,24 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defclass html-link-ref (link-ref) () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref - :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels + (:default-initargs :fmtstr #'ho-fmtstr-html-ref + :fmtstr-labels #'ho-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" :ampersand "&")) (defclass xhtml-link-ref (link-ref) () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref - :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels + (:default-initargs :fmtstr #'ho-fmtstr-html-ref + :fmtstr-labels #'ho-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" :ampersand "&")) (defclass xml-link-ref (link-ref) () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref - :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels + (:default-initargs :fmtstr #'ho-fmtstr-xml-ref + :fmtstr-labels #'ho-fmtstr-xml-ref-labels :href-head "xmllink xlink:type=\"simple\" xlink:href=" :href-end "xmllink" :ampersand "&") @@ -655,12 +706,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (funcall (funcall (obj-data-value-func fmt) x) x)))) ;; make list of reference link fields for printing to refstr template - (dolist (field (hyperobject-class-ref-fields x)) + (dolist (ref (ho-references x)) (let ((link-start - (make-link-start x (link-ref fmt) (car field) (cadr field) - (nth (position (car field) (hyperobject-class-fields x) :key #'car) field-values) - (append (caddr field) refvars))) - (link-end (make-link-end x (link-ref fmt) (car field)))) + (make-link-start x (link-ref fmt) (name ref) (lookup ref) + (nth (position (name ref) (ho-fields x) + :key #'(lambda (x) (name x))) + field-values) + (append (link-parameters ref) refvars))) + (link-end (make-link-end x (link-ref fmt) (name ref)))) (push link-start refvalues) (push link-end refvalues))) (setq refvalues (nreverse refvalues)) @@ -698,9 +751,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (when objs (let ((objlist (mklist objs))) (dolist (obj objlist) - (awhen (hyperobject-class-subobjects-lists obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) + (awhen (ho-subobjects obj) ;; access list of functions + (dolist (subobj it) ;; for each child function + (awhen (funcall (reader subobj) obj) (load-all-subobjects it)))))) objs)) @@ -724,12 +777,12 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (fmt-obj-start obj fmt strm indent) (fmt-obj-data obj fmt strm (1+ indent) label refvars) (if subobjects - (awhen (hyperobject-class-subobjects-lists obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) ;; access set of child objects - (print-hyperobject-class it fmt strm label - (1+ indent) english-only-function - subobjects refvars))))) + (awhen (ho-subobjects obj) ;; access list of functions + (dolist (subobj it) ;; for each child function + (awhen (funcall (reader subobj) obj) ;; access set of child objects + (print-hyperobject-class it fmt strm label + (1+ indent) english-only-function + subobjects refvars))))) (fmt-obj-end obj fmt strm indent))) (fmt-list-end (car objs) fmt strm indent nobjs)) t)) @@ -750,11 +803,6 @@ Format is ((field-name field-lookup-func other-link-params) ...)") objs) -(defclass hyperobject () - () - (:metaclass hyperobject-class)) - - (defmethod print-object ((obj hyperobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) (let ((fmt (make-instance 'hyperobject::textformat)))