X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=820556800fce09101bc6ee51165f71d41a41f10d;hb=2cbed6bd021bbecfe70496c8e4addb0f8a3f13cb;hp=cf92ed09dec131e097849e21fc964bb0d53c4ab6;hpb=9d3930d7b2bacd5327ce55ad9fb0ce1392fe746b;p=hyperobject.git diff --git a/views.lisp b/views.lisp index cf92ed0..8205568 100644 --- a/views.lisp +++ b/views.lisp @@ -7,445 +7,734 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.1 2002/11/25 04:47:23 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; $Id: views.lisp,v 1.62 2003/07/19 20:32:48 kevin Exp $ ;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) - -(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)) +(in-package #:hyperobject) + + +(defclass object-view () + ((object-class :initform nil :initarg :object-class + :accessor object-class + :documentation "Class of object to be viewed.") + (slots :initform nil :initarg :slots :accessor slots + :documentation "List of effective slots for object to be viewed.") + (id :initform nil :initarg :id :accessor id + :documentation "id for this view.") + (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.") + (printer :initform nil :initarg :printer :accessor printer + :documentation "default function that prints the object") + ;; + (file-start-str :type (or string null) :initform nil :initarg :file-start-str + :accessor file-start-str) + (file-end-str :type (or string null) :initform nil :initarg :file-end-str + :accessor file-end-str) + (list-start-printer :type (or string function null) :initform nil + :initarg :list-start-printer + :accessor list-start-printer) + (list-start-indent :initform nil :initarg :list-start-indent + :accessor list-start-indent) + (list-end-printer :type (or string function null) :initform nil + :initarg :list-end-printer + :accessor list-end-printer) + (list-end-indent :initform nil :initarg :list-end-indent + :accessor list-end-indent) + (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer + :accessor obj-start-printer) + (obj-start-indent :initform nil :initarg :obj-start-indent + :accessor obj-start-indent) + (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer + :accessor obj-end-printer) + (obj-end-indent :initform nil :initarg :obj-end-indent + :accessor obj-end-indent) + (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer + :accessor subobj-start-printer) + (subobj-start-indent :initform nil :initarg :subobj-start-indent + :accessor subobj-start-indent) + (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer + :accessor subobj-end-printer) + (subobj-end-indent :initform nil :initarg :subobj-end-indent + :accessor subobj-end-indent) + (obj-data-indent :initform nil :initarg :obj-data-indent + :accessor obj-data-indent) + (obj-data-printer :type (or function null) :initform nil + :initarg :obj-data-printer + :accessor obj-data-printer) + (obj-data-print-code :type (or function null) :initform nil + :initarg :obj-data-print-code + :accessor obj-data-print-code) + (obj-data-start-printer :type (or function string null) :initform nil + :initarg :obj-data-start-printer + :accessor obj-data-start-printer) + (obj-data-end-printer :type (or string null) :initform nil + :initarg :obj-data-end-printer + :accessor obj-data-end-printer) + (indenter :type (or function null) :initform nil + :accessor indenter + :documentation "Function that performs hierarchical indenting") + (link-slots :type list :initform nil + :documentation "List of slot names that have hyperlinks" + :accessor link-slots) + (link-page :type (or string null) :initform nil + :initarg :link-page + :accessor link-page) + (link-href-start :type (or string null) :initform nil :initarg :link-href-start + :accessor link-href-start) + (link-href-end :type (or string null) :initform nil :initarg :link-href-end + :accessor link-href-end) + (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand + :accessor link-ampersand)) + (:default-initargs :link-page "lookup-func1") + (:documentation "View class for a hyperobject")) + + +(defun get-default-view-id (obj-cl) + (aif (views obj-cl) + (id (car it)) + :compact-text)) + +(defun find-view-id-in-class-precedence (obj-cl vid) + "Looks for a view in class and parent classes" + (when (typep obj-cl 'hyperobject-class) + (aif (find vid (views obj-cl) :key #'id :test #'eq) + it + (let (cpl) + (handler-case + (setq cpl (class-precedence-list obj-cl)) + (error (e) + (declare (ignore e)) + ;; can't get cpl unless class finalized + (make-instance (class-name obj-cl)) + (setq cpl (class-precedence-list obj-cl)))) + (find-view-id-in-class-precedence (second cpl) vid))))) + + +(defun get-view-id (obj vid &optional slots) + "Find or make a category view for an object" + (let ((obj-cl (class-of obj))) + (unless vid + (setq vid (get-default-view-id obj-cl))) + (aif (find-view-id-in-class-precedence obj-cl vid) + it + (let ((view + (make-instance 'object-view + :object-class (class-name obj-cl) + :id vid + :slots slots))) + (push view (views obj-cl)) + view)))) + +;;;; ************************************************************************* +;;;; Metaclass Intialization +;;;; ************************************************************************* + +(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)))) + (setf (views cl) + (loop for view-def in (direct-views cl) + collect (make-object-view cl view-def)))) + +(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) + (make-instance 'object-view + :object-class (class-name cl) + :id :compact-text)) + ((consp view-def) + (make-instance 'object-view + :object-class (class-name cl) + :id (getf view-def :id) + :slots (getf view-def :slots) + :source-code (getf view-def :source-code))) + (t + (error "Invalid parameter to make-object-view: ~S" view-def)))) + +(defmethod initialize-instance :after ((self object-view) + &rest initargs + &key + &allow-other-keys) + (initialize-view self)) + +(defun initialize-view (view) + "Calculate all view slots for a hyperobject class" + (let ((obj-cl (find-class (object-class view)))) + (cond + ((source-code view) + (initialize-view-by-source-code view)) + ((id view) + (initialize-view-by-id obj-cl view)) + (t + (setf (id view) :compact-text) + (initialize-view-by-id obj-cl view))))) + + + +(defun initialize-view-by-source-code (view) + "Initialize a view based upon a source code" + (let* ((source-code (source-code view)) + (printer `(lambda + (,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,(intern (symbol-name '#:s) + (symbol-package (object-class view)))) + (declare (ignorable + ,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,(intern (symbol-name '#:s) + (symbol-package (object-class view))))) + (with-slots ,(slots view) + ,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,@source-code)))) + (setf (printer view) + (compile nil (eval printer))))) + +(defmacro write-simple (v s) + `(typecase ,v + (string + (write-string ,v ,s)) + (fixnum + (write-fixnum ,v ,s)) + (symbol + (write-string (symbol-name ,v) ,s)) + (t + (write-string (write-to-string ,v) ,s)))) + +(defun write-ho-value (obj name type formatter cdata strm) + (declare (ignorable type)) + (let* ((slot-data (slot-value obj name)) + (fmt-data (if formatter + (funcall formatter slot-data) + slot-data))) + (if cdata + (write-xml-cdata fmt-data strm) + (write-simple fmt-data strm)))) + +(defun ppfc-html (title name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string "" s) print-func)) + +(defun ppfc-xml (tag name type formatter cdata print-func) + (vector-push-extend '(write-char #\< s) print-func) + (vector-push-extend `(write-string ,tag s) print-func) + (vector-push-extend '(write-char #\> s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,tag s) print-func) + (vector-push-extend '(write-char #\> s) print-func)) + +(defun ppfc-html-labels (label name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html label name type formatter cdata print-func)) + +(defun ppfc-xhtml-labels (label tag name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html tag name type formatter cdata print-func)) + +(defun ppfc-xml-labels (label tag name type formatter cdata print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-xml tag name type formatter cdata print-func)) + +(defun ppfc-html-link (name type formatter cdata nlink print-func) + (declare (fixnum nlink)) + (vector-push-extend '(write-char #\< s) print-func) + (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) + (vector-push-extend '(write-char #\> s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func) + (vector-push-extend '(write-char #\> s) print-func)) + +(defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html-link name type formatter cdata nlink print-func)) + +(defun push-print-fun-code (vid slot nlink print-func) + (let* ((formatter (esd-print-formatter slot)) + (name (slot-definition-name slot)) + (user-name (esd-user-name slot)) + (xml-user-name (escape-xml-string user-name)) + (xml-tag (escape-xml-string user-name)) + (type (slot-value slot 'type)) + (cdata (not (null + (and (in vid :xml :xhtml :xml-link :xhtml-link + :xml-labels :ie-xml-labels + :xhtml-link-labels :xml-link-labels :ie-xml-link + :ie-xml-link-labels) + (or formatter + (lisp-type-is-a-string type)))))) + (hyperlink (esd-hyperlink slot))) + + (case vid + (:compact-text + (vector-push-extend + `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + (:compact-text-labels + (vector-push-extend `(write-string ,user-name s) print-func) + (vector-push-extend '(write-char #\space s) print-func) + (vector-push-extend + `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + ((or :html :xhtml) + (ppfc-html user-name name type formatter cdata print-func)) + (:xml + (ppfc-xml xml-tag name type formatter cdata print-func)) + (:html-labels + (ppfc-html-labels user-name name type formatter cdata print-func)) + (:xhtml-labels + (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) + (:xml-labels + (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func)) + ((or :html-link :xhtml-link) + (if hyperlink + (ppfc-html-link name type formatter cdata nlink print-func) + (ppfc-html user-name name type formatter cdata print-func))) + ((or :xml-link :ie-xml-link) + (if hyperlink + (ppfc-html-link name type formatter cdata nlink print-func) + (ppfc-xml xml-tag name type formatter cdata print-func))) + (:html-link-labels + (if hyperlink + (ppfc-html-link-labels user-name name type formatter cdata nlink + print-func) + (ppfc-html-labels user-name name type formatter cdata print-func))) + (:xhtml-link-labels + (if hyperlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink + print-func) + (ppfc-xhtml-labels xml-tag user-name name type formatter cdata + print-func))) + ((or :xml-link-labels :ie-xml-link-labels) + (if hyperlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink + print-func) + (ppfc-xml-labels xml-tag user-name name type formatter cdata + print-func)))))) + + +(defun view-has-links-p (view) + (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link + :html-link-labels :xhtml-link-labels :xml-link-labels + :ie-xml-link-labels)) + +(defun creatable-view-id-p (obj-cl vid) + "Returns T if a view id can be created for this class" + (declare (ignore obj-cl)) + (in vid :compact-text :compact-text-labels + :html :html-labels :html-link-labels + :xhtml :xhtml-labels :xhtml-link-labels + :xhtml-link :html-link + :xml :xml-labels :xml-link :ie-xml-link + :xml-link-labels :ie-xml-link-labels + :display-table :edit-table)) + +(defun initialize-view-by-id (obj-cl view) + "Initialize a view based upon a preset vid" + (unless (creatable-view-id-p obj-cl (id view)) + (error "Unable to automatically create view id ~A" (id view))) - (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*))) + (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) + + (let ((links '()) + (print-func (make-array 10 :fill-pointer 0 :adjustable t))) + + (do* ((slots (slots view) (cdr slots)) + (slot-name (car slots) (car slots)) + (slot (find-slot-by-name obj-cl slot-name) + (find-slot-by-name obj-cl slot-name))) + ((null slots)) + (unless slot + (error "Slot ~A is not found in class ~S" slot-name obj-cl)) + + (push-print-fun-code (id view) slot (length links) print-func) + (when (> (length slots) 1) + (vector-push-extend '(write-char #\space s) print-func)) + + (when (and (view-has-links-p view) (esd-hyperlink slot)) + (push (slot-definition-name slot) links))) + + (vector-push-extend 'x print-func) ;; return object + (setf (obj-data-print-code view) `(lambda (x s links) + (declare (ignorable s links)) + ,@(map 'list #'identity print-func))) + (setf (obj-data-printer view) + (compile nil (eval (obj-data-print-code view)))) -;;;; 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)) + (setf (link-slots view) (nreverse links))) + + (finalize-view-by-id view) + view) + +(defun finalize-view-by-id (view) + (case (id view) + ((or :compact-text :compact-text-labels) + (initialize-text-view view)) + ((or :html :html-labels) + (initialize-html-view view)) + ((or :xhtml :xhtml-labels) + (initialize-xhtml-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-xhtml-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 Data Format Section +;;;; ************************************************************************* + (defun class-name-of (obj) (string-downcase (class-name (class-of obj)))) -(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: