X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=inline;f=views.lisp;h=f4f075742d6156bb55f0af351f9cd5bd636b65e2;hb=47a7911aaa793adcce5add7bc912ded4bff18d99;hp=f1016a14599de1f25f6d43dc62d4d98293e1854e;hpb=31bfe50a3006d439e073be4336e50aae98707eb1;p=hyperobject.git diff --git a/views.lisp b/views.lisp index f1016a1..f4f0757 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.10 2002/12/06 20:46:51 kevin Exp $ +;;;; $Id: views.lisp,v 1.18 2002/12/26 11:57:15 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -19,563 +19,533 @@ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(defclass object-view () + ((object-class :initform nil :initarg :object-class :accessor object-class + :documentation "Name of class for object to be viewed.") + (slots :initform nil :initarg :slots :accessor slots + :documentation "List of effective slots for object to be viewed.") + (name :initform nil :initarg :name :accessor name + :documentation "Name for this view.") + (category :initform nil :initarg :category :accessor category + :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") + (source-code :initform nil :initarg :source-code :accessor source-code + :documentation "Source code for generating view.") + (country-language :initform :en :initarg :country-language + :documentation "Country's Language for this view.") + ;; + (file-start-str :type string :initform nil :initarg :file-start-str + :accessor file-start-str) + (file-end-str :type string :initform nil :initarg :file-end-str + :accessor file-end-str) + (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr + :accessor list-start-fmtstr) + (list-start-value-func :type function :initform nil + :initarg :list-start-value-func + :accessor list-start-value-func) + (list-start-indent :initform nil :initarg :list-start-indent + :accessor list-start-indent) + (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr + :accessor list-end-fmtstr) + (list-end-value-func :type function :initform nil + :initarg :list-end-value-func + :accessor list-end-value-func) + (list-end-indent :initform nil :initarg :list-end-indent + :accessor list-end-indent) + (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr + :accessor obj-start-fmtstr) + (obj-start-value-func :initform nil :initarg :obj-start-value-func + :accessor obj-start-value-func) + (obj-start-indent :initform nil :initarg :obj-start-indent + :accessor obj-start-indent) + (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr + :accessor obj-end-fmtstr) + (obj-end-value-func :type function :initform nil + :initarg :obj-end-value-func + :accessor obj-end-value-func) + (obj-end-indent :initform nil :initarg :obj-end-indent + :accessor obj-end-indent) + (obj-data-indent :initform nil :initarg :obj-data-indent + :accessor obj-data-indent) + (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr + :accessor obj-data-fmtstr) + (obj-data-end-fmtstr :type string :initform nil + :initarg :obj-data-end-fmtstr + :accessor obj-data-end-fmtstr) + (obj-data-value-func :type function :initform nil + :initarg :obj-data-value-func + :accessor obj-data-value-func) + (link-slots :type list :initform nil + :documentation "List of slot names that have hyperlinks" + :accessor link-slots) + (link-page-name :type string :initform nil :initarg :link-page-name + :accessor link-page-name) + (link-href-start :type string :initform nil :initarg :link-href-start + :accessor link-href-start) + (link-href-end :type string :initform nil :initarg :link-href-end + :accessor link-href-end) + (link-ampersand :type string :initform nil :initarg :link-ampersand + :accessor link-ampersand)) + (:default-initargs :link-page-name "disp-func1") + (:documentation "View class for a hyperobject")) + + +(defun get-category-view (obj category &optional slots) + "Find or make a category view for an object" + (let ((obj-class (class-of obj))) + (if (null category) + (default-view obj-class) + (aif (find category (views obj-class) :key #'category) + it + (let ((view + (make-instance 'object-view :object-class (class-name obj-class) + :category category + :slots slots))) + (push view (views obj-class)) + view))))) + ;;;; ************************************************************************* ;;;; Metaclass Intialization ;;;; ************************************************************************* -(defun finalize-hyperlinks (cl) - (let ((hyperlinks '())) - (dolist (esd (class-slots cl)) - (awhen (slot-value esd 'hyperlink) - (push - (make-instance 'hyperlink - :name (slot-definition-name esd) - :lookup it - :link-parameters (slot-value esd 'hyperlink-parameters)) - hyperlinks))) - (setf (slot-value cl 'hyperlinks) hyperlinks))) - - (defun finalize-views (cl) + "Finalize all views that are given on a objects initialization" + (unless (default-print-slots cl) + (setf (default-print-slots cl) + (mapcar #'slot-definition-name (class-slots cl)))) + (let ((views '())) + (dolist (view-def (views cl)) + (push (make-object-view cl view-def) views)) + (setf (views cl) (nreverse views))) + (cond + ((default-view cl) + (setf (default-view cl) (make-object-view cl (default-view cl)))) + ((car (views cl)) + (setf (default-view cl) (make-object-view cl (car (views cl))))) + (t + (setf (default-view cl) (make-object-view cl :default))))) + +(defun make-object-view (cl view-def) + "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op" + (cond + ((typep view-def 'object-view) + view-def) + ((eq view-def :default) + (let* ((name (class-name cl)) + (view (make-instance 'object-view :name "automatic" + :object-class name + :category :compact-text))) + view)) + ((consp view-def) + (eval `(make-instance ,view-def))) + (t + (error "Invalid parameter to make-object-view: ~S" view-def)))) + +(defmethod initialize-instance :after ((view object-view) + &rest initargs &key &allow-other-keys) + (initialize-view (find-class (object-class view)) view)) + +(defun initialize-view (obj-cl view) "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 "") + (cond + ((category view) + (initialize-view-by-category obj-cl view)) + ((source-code view) + (initialize-view-by-source-code obj-cl view)) + (t + (setf (category view) :compact-text) + (initialize-view-by-category obj-cl view)))) + +(defun initialize-view-by-source-code (obj-cl view) + "Initialize a view based upon a source code" + (let ((source-code (source-code view))) + (error "not implemented") + ) + ) + + +(defun initialize-view-by-category (obj-cl view) + "Initialize a view based upon a preset category" + (let ((fmtstr nil) (first-field t) (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (class-name cl))) - (hyperlinks 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))) + (links '()) + (category (category view))) + + (unless (in category :compact-text :compact-text-labels + :html :html-labels :html-link-labels + :xhtml :xhtml-labels :xhtml-link-labels + :xml :xml-labels :xml-link :ie-xml-link + :xml-link-labels :ie-xml-link-labels) + (error "Unknown view category ~A" category)) + + (unless (slots view) + (setf (slots view) (default-print-slots obj-cl))) + (dolist (slot-name (slots view)) + (let ((slot (find-slot-by-name obj-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 'hyperlink) - (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 'hyperlink :name name - :lookup (slot-value slot 'hyperlink)) - hyperlinks)) - (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))) + (error "Slot ~A is not found in class ~S" slot-name obj-cl)) + (let* ((name (slot-definition-name slot)) + (namestr-lower (string-downcase (symbol-name name))) + (xml-namestring (escape-xml-string namestr-lower)) + (xml-tag (escape-xml-string namestr-lower)) + (type (slot-value slot 'type)) + (print-formatter (esd-print-formatter slot))) + + (cond + (first-field + (setq fmtstr "") + (setq first-field nil)) + (t + (string-append fmtstr " "))) + + (let ((value-fmt + (case type + ((or :integer :fixnum) + "~d") + (:boolean + "~a") + (otherwise + "~a")))) + (case category + (:compact-text + (string-append fmtstr value-fmt)) + (:compact-text-labels + (string-append fmtstr namestr-lower " " value-fmt)) + ((or :html :xhtml) + (string-append fmtstr (concatenate 'string "" value-fmt ""))) + (:xml + (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "" namestr-lower ">"))) + (:html-labels + (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))) + (:xhtml-labels + (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt ""))) + (:xml-labels + (string-append fmtstr (concatenate 'string " <" xml-tag ">" value-fmt "" xml-tag ">"))) + ((or :html-link :xhtml-link) + (push name links) + (if (esd-hyperlink slot) + (string-append fmtstr "<~~a>" value-fmt "~~a>") + (string-append fmtstr (concatenate 'string "" value-fmt "")))) + ((or :xml-link :ie-xml-link) + (push name links) + (if (esd-hyperlink slot) + (string-append fmtstr "<~~a>" value-fmt "~~a>") + (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "" xml-tag ">")))) + (:html-link-labels + (push name links) + (if (esd-hyperlink slot) + (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "~~a>") + (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))) + (:xhtml-link-labels + (push name links) + (if (esd-hyperlink slot) + (string-append fmtstr "" xml-namestr " <~~a>" value-fmt "~~a>") + (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt "")))) + ((or :xml-link-labels :ie-xml-link-labels) + (push name links) + (if (esd-hyperlink slot) + (string-append fmtstr " <~~a>" value-fmt "~~a>") + (string-append fmtstr (concatenate 'string " <" xml-tag ">" value-fmt "" xml-tag ">"))))) + ) ;; let value-fmt + + (let ((func (if print-formatter + `(,print-formatter (slot-value x (quote ,name))) + `(slot-value x (quote ,name))))) + (when (and (in category :xml :xhtml :xml-link :xhtml-link + :xhtml-link-labels :xml-link-labels :ie-xml-link + :ie-xml-link-labels) + (or print-formatter + (string-equal (write-to-string type) "string"))) + (setq func `(kmrcl:xml-cdata ,func))) + (push func value-func)) ))) + + (when value-func + (setq value-func + (compile nil (eval `(lambda (x) (values ,@(nreverse value-func))))))) + + (setf (obj-data-fmtstr view) fmtstr) + (setf (obj-data-value-func view) value-func) + (setf (link-slots view) (nreverse links)) - (setf (slot-value cl 'hyperlinks) hyperlinks) - - (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)) + (case category + ((or :compact-text :compact-text-labels) + (initialize-text-view view)) + ((or :html :xhtml :html-labels :xhtml-labels) + (initialize-html-view view)) + ((or :xml :xml-labels) + (initialize-xml-view view)) + ((or :html-link :html-link-labels) + (initialize-html-view view) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) + ((or :xhtml-link :xhtml-link-labels) + (initialize-html-view view) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) + ((or :xml-link :xml-link-labels) + (initialize-xml-view view) + (setf (link-href-start view) + "xmllink xlink:type=\"simple\" xlink:href=") + (setf (link-href-end view) "xmllink") + (setf (link-ampersand view) "&")) + ((or :ie-xml-link :ie-xml-link-labels) + (initialize-xml-view view) + (setf (link-href-start view) "html:a href=") + (setf (link-href-end view) "html:a") + (setf (link-ampersand view) "&")))) + view) ;;;; ************************************************************************* ;;;; View Data Format Section ;;;; ************************************************************************* -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xhtmlformat* nil) -(defparameter *default-xhtmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-ie-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) - (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xhtml *default-xhtmlformat*) - (:xhtmlref *default-xhtmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:ie-xmlref *default-ie-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print hyperobject-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :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-end-fmtstr "~%" - :obj-data-value-func #'hyperobject-class-value-func)) - - (defun class-name-of (obj) (string-downcase (class-name (class-of obj)))) +(defun text-list-start-value-func (obj nitems) + (values (hyperobject-class-user-name obj) nitems)) + (defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "
~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "~a~p:
~a~p:
~a~p:
~a~p: