X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=d22f6232a9fc0acb2c7ea20dfa36bc52d3a416e8;hb=0817a8721cbefca2205dcde535ff6b164033abef;hp=6c102965ef1cbfef5b86a54fe61c4777d48c93bc;hpb=6ff5ef506bb52b4a98cb7a0b3726f5d3a9637944;p=hyperobject.git diff --git a/views.lisp b/views.lisp index 6c10296..d22f623 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -21,10 +21,8 @@ :documentation "Class of 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.") + (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 @@ -95,21 +93,42 @@ (:documentation "View class for a hyperobject")) -(defun get-category-view (obj category &optional slots) +(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-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 (find-class obj-class) - :category category - :slots slots))) - (push view (views obj-class)) - view))))) - + (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 ;;;; ************************************************************************* @@ -119,15 +138,9 @@ (unless (default-print-slots cl) (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) - (let ((views '())) - (dolist (view-def (direct-views cl)) - (push (make-object-view cl view-def) views)) - (setf (views cl) (nreverse views))) - (cond - ((views cl) - (setf (default-view cl) (car (views cl)))) - (t - (setf (default-view cl) (make-object-view cl :default))))) + (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" @@ -135,22 +148,21 @@ ((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 (class-name cl) - :category :compact-text))) - view)) + (make-instance 'object-view + :object-class (class-name cl) + :id :compact-text)) ((consp view-def) (make-instance 'object-view :object-class (class-name cl) - :name (getf view-def :name) + :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 + &key &allow-other-keys) (initialize-view self)) @@ -158,21 +170,33 @@ "Calculate all view slots for a hyperobject class" (let ((obj-cl (find-class (object-class view)))) (cond - ((category view) - (initialize-view-by-category obj-cl view)) ((source-code view) (initialize-view-by-source-code view)) + ((id view) + (initialize-view-by-id obj-cl view)) (t - (setf (category view) :compact-text) - (initialize-view-by-category obj-cl view))))) + (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)) - (*package* (symbol-package (object-class view))) - (printer `(lambda (x s) - (declare (ignorable x s)) - ,@source-code))) + (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))))) @@ -247,7 +271,7 @@ (vector-push-extend '(write-string " " s) print-func) (ppfc-html-link name type formatter cdata nlink print-func)) -(defun push-print-fun-code (category slot 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)) @@ -255,7 +279,7 @@ (xml-tag (escape-xml-string user-name)) (type (slot-value slot 'type)) (cdata (not (null - (and (in category :xml :xhtml :xml-link :xhtml-link + (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) @@ -263,7 +287,7 @@ (lisp-type-is-a-string type)))))) (hyperlink (esd-hyperlink slot))) - (case category + (case vid (:compact-text (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) @@ -310,20 +334,25 @@ (defun view-has-links-p (view) - (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link + (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 initialize-view-by-category (obj-cl view) - "Initialize a view based upon a preset category" - (unless (in (category view) :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) - (error "Unknown view category ~A" (category view))) +(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))) (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) @@ -338,7 +367,7 @@ (unless slot (error "Slot ~A is not found in class ~S" slot-name obj-cl)) - (push-print-fun-code (category view) slot (length links) print-func) + (push-print-fun-code (id view) slot (length links) print-func) (when (> (length slots) 1) (vector-push-extend '(write-char #\space s) print-func)) @@ -354,11 +383,11 @@ (setf (link-slots view) (nreverse links))) - (finalize-view-by-category view) + (finalize-view-by-id view) view) -(defun finalize-view-by-category (view) - (case (category view) +(defun finalize-view-by-id (view) + (case (id view) ((or :compact-text :compact-text-labels) (initialize-text-view view)) ((or :html :html-labels) @@ -390,12 +419,6 @@ (setf (link-ampersand view) "&")))) -(defun make-std-object-slots-view (class-name slots) - #'(lambda (obj strm) - ) - - ) - ;;;; ************************************************************************* ;;;; View Data Format Section ;;;; ************************************************************************* @@ -497,16 +520,17 @@ (write-char #\newline strm)) (defun initialize-xml-view (view) - (setf (file-start-str view) "") ; (std-xml-header) - (setf (list-start-indent view) t) - (setf (list-start-printer view) #'xmlformat-list-start-func) - (setf (list-end-indent view) t) - (setf (list-end-printer view) #'xmlformat-list-end-func) - (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view))) - (setf (obj-start-indent view) t) - (setf (subobj-end-printer view) (format nil "~%" (object-class-name view))) - (setf (subobj-end-indent view) nil) - (setf (obj-data-indent view) nil)) + (let ((name (string-downcase (symbol-name (object-class view))))) + (setf (file-start-str view) "") ; (std-xml-header) + (setf (list-start-indent view) t) + (setf (list-start-printer view) #'xmlformat-list-start-func) + (setf (list-end-indent view) t) + (setf (list-end-printer view) #'xmlformat-list-end-func) + (setf (obj-start-printer view) (format nil "<~(~a~)>" name)) + (setf (obj-start-indent view) t) + (setf (subobj-end-printer view) (format nil "~%" name)) + (setf (subobj-end-indent view) nil) + (setf (obj-data-indent view) nil))) ;;; File Start and Ends @@ -656,18 +680,18 @@ (load-all-subobjects it)))) objs) -(defun view-subobjects (obj strm &optional category (indent 0) filter +(defun view-subobjects (obj strm &optional vid (indent 0) filter subobjects refvars link-printer) (when (hyperobject-class-subobjects obj) (dolist (subobj (hyperobject-class-subobjects obj)) (aif (slot-value obj (name-slot subobj)) (view-hyperobject - it (get-category-view (car (mklist it)) category) - category strm (1+ indent) filter subobjects refvars + it (get-view-id (car (mklist it)) vid) + strm vid (1+ indent) filter subobjects refvars link-printer))))) -(defun view-hyperobject (objs view strm &optional category (indent 0) filter +(defun view-hyperobject (objs view strm &optional vid (indent 0) filter subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" (let-when (objlist (mklist objs)) @@ -688,24 +712,22 @@ (fmt-obj-end obj view strm indent) (when subobjects (fmt-subobj-start obj view strm indent) - (view-subobjects obj category strm indent filter subobjects + (view-subobjects obj strm vid indent filter subobjects refvars link-printer) (fmt-subobj-end obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) -(defun view (objs &key (stream *standard-output*) category view +(defun view (objs &key (stream *standard-output*) vid view filter subobjects refvars file-wrapper link-printer) "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject" (let-when (objlist (mklist objs)) - (when category - (setq view (get-category-view (car objlist) category))) (unless view - (setq view (default-view (class-of (car objlist))))) + (setq view (get-view-id (car objlist) vid))) (when file-wrapper (fmt-file-start view stream)) - (view-hyperobject objlist view stream category 0 filter subobjects refvars + (view-hyperobject objlist view stream vid 0 filter subobjects refvars link-printer) (when file-wrapper (fmt-file-end view stream)))