X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=views.lisp;h=6c102965ef1cbfef5b86a54fe61c4777d48c93bc;hb=6ff5ef506bb52b4a98cb7a0b3726f5d3a9637944;hp=6776e39e1bc57a8455aa4a7711f09e7a4de281e4;hpb=3537a8422aeb2817b41ee835c5ff45ba1d973c98;p=hyperobject.git diff --git a/views.lisp b/views.lisp index 6776e39..6c10296 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.56 2003/06/17 17:50:45 kevin Exp $ +;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -16,10 +16,7 @@ (defclass object-view () - ((object-class-name :initform nil :initarg :object-class-name - :accessor object-class-name - :documentation "Name of class of object to be viewed.") - (object-class :initform nil :initarg :object-class + ((object-class :initform nil :initarg :object-class :accessor object-class :documentation "Class of object to be viewed.") (slots :initform nil :initarg :slots :accessor slots @@ -32,6 +29,8 @@ :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) @@ -92,7 +91,7 @@ :accessor link-href-end) (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand :accessor link-ampersand)) - (:default-initargs :link-page "disp-func1") + (:default-initargs :link-page "lookup-func1") (:documentation "View class for a hyperobject")) @@ -105,10 +104,9 @@ it (let ((view (make-instance 'object-view - :object-class-name (class-name obj-class) - :object-class obj-class - :category category - :slots slots))) + :object-class (find-class obj-class) + :category category + :slots slots))) (push view (views obj-class)) view))))) @@ -122,14 +120,12 @@ (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) (let ((views '())) - (dolist (view-def (views cl)) + (dolist (view-def (direct-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))))) + ((views cl) + (setf (default-view cl) (car (views cl)))) (t (setf (default-view cl) (make-object-view cl :default))))) @@ -141,44 +137,51 @@ ((eq view-def :default) (let* ((name (class-name cl)) (view (make-instance 'object-view :name "automatic" - :object-class-name name - :object-class cl + :object-class (class-name cl) :category :compact-text))) view)) ((consp view-def) - (apply #'make-instance 'object-view view-def)) + (make-instance 'object-view + :object-class (class-name cl) + :name (getf view-def :name) + :source-code (getf view-def :source-code))) (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 (object-class view) view)) +(defmethod initialize-instance :after ((self object-view) + &rest initargs + &key + &allow-other-keys) + (initialize-view self)) -(defun initialize-view (obj-cl view) +(defun initialize-view (view) "Calculate all view slots for a hyperobject class" - (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) + (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)) + (t + (setf (category view) :compact-text) + (initialize-view-by-category obj-cl view))))) + +(defun initialize-view-by-source-code (view) "Initialize a view based upon a source code" - (let ((source-code (source-code view))) - (error "not implemented") - ) - ) + (let* ((source-code (source-code view)) + (*package* (symbol-package (object-class view))) + (printer `(lambda (x s) + (declare (ignorable x s)) + ,@source-code))) + (setf (printer view) + (compile nil (eval printer))))) (defmacro write-simple (v s) `(typecase ,v (string (write-string ,v ,s)) - #+allegro (fixnum - (excl::print-fixnum ,s 10 ,v)) + (write-fixnum ,v ,s)) (symbol (write-string (symbol-name ,v) ,s)) (t @@ -318,7 +321,8 @@ :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) + :xml-link-labels :ie-xml-link-labels + :display-table :edit-table) (error "Unknown view category ~A" (category view))) (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) @@ -386,6 +390,12 @@ (setf (link-ampersand view) "&")))) +(defun make-std-object-slots-view (class-name slots) + #'(lambda (obj strm) + ) + + ) + ;;;; ************************************************************************* ;;;; View Data Format Section ;;;; ************************************************************************* @@ -406,6 +416,7 @@ (setf (list-start-printer view) (compile nil (eval '(lambda (obj nitems indent strm) + (declare (ignore indent)) (write-user-name-maybe-plural obj nitems strm) (write-char #\: strm) (write-char #\Newline strm))))) @@ -415,7 +426,9 @@ (setf (indenter view) #'indent-spaces)) (defun html-list-start-func (obj nitems indent strm) - (write-string "
" strm) + (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) (write-char #\newline strm) @@ -424,7 +437,7 @@ (defun initialize-html-view (view) (initialize-text-view view) - (setf (indenter view) #'indent-html-spaces) + (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) @@ -439,28 +452,33 @@ (setf (obj-data-indent view) nil)) (defun xhtml-list-start-func (obj nitems indent strm) - (write-string "
" strm) - (indent-html-spaces indent strm) + (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) + (write-string "
" strm) (write-char #\newline strm)) +(defun html-obj-start (obj indent strm) + (declare (ignore obj indent)) + (write-string "
" strm)) + (defun initialize-xhtml-view (view) (initialize-text-view view) - (setf (indenter view) #'indent-html-spaces) + (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) nil) (setf (list-start-printer view) #'xhtml-list-start-func) - (setf (list-end-printer view) (format nil "~%")) + (setf (list-end-printer view) (format nil "
~%")) (setf (list-end-indent view) nil) (setf (obj-start-indent view) nil) - (setf (obj-start-printer view) nil) + (setf (obj-start-printer view) #'html-obj-start) (setf (obj-end-printer view) (format nil "
~%")) - (setf (obj-data-start-printer view) "
") - (setf (obj-data-end-printer view) nil) - (setf (obj-end-indent view) nil) - (setf (obj-data-indent view) t)) + (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) (write-string "" strm) @@ -478,7 +497,6 @@ (write-char #\newline strm)) (defun initialize-xml-view (view) - (initialize-text-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) @@ -532,7 +550,7 @@ (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj strm)))) + (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) @@ -550,7 +568,7 @@ (awhen (subobj-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj strm)))) + (funcall it obj indent strm)))) (defun fmt-subobj-end (obj view strm indent) (when (subobj-end-indent view) @@ -638,7 +656,18 @@ (load-all-subobjects it)))) objs) -(defun view-hyperobject (objs view category strm &optional (indent 0) filter +(defun view-subobjects (obj strm &optional category (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 + link-printer))))) + + +(defun view-hyperobject (objs view strm &optional category (indent 0) filter subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" (let-when (objlist (mklist objs)) @@ -651,20 +680,17 @@ (*print-level* nil)) (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) - (unless (and filter (not (funcall filter obj))) - (fmt-obj-start obj view strm indent) - (fmt-obj-data obj view strm (1+ indent) refvars link-printer) - (fmt-obj-end obj view strm indent) - (fmt-subobj-start obj view strm indent) - (when (and subobjects (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 link-printer)))) - (fmt-subobj-end obj view strm indent))) + (awhen (printer view) + (funcall it obj strm)) + (unless (and filter (not (funcall filter obj))) + (fmt-obj-start obj view strm indent) + (fmt-obj-data obj view strm (1+ indent) refvars link-printer) + (fmt-obj-end obj view strm indent) + (when subobjects + (fmt-subobj-start obj view strm indent) + (view-subobjects obj category strm indent filter subobjects + refvars link-printer) + (fmt-subobj-end obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) @@ -679,7 +705,7 @@ (setq view (default-view (class-of (car objlist))))) (when file-wrapper (fmt-file-start view stream)) - (view-hyperobject objlist view category stream 0 filter subobjects refvars + (view-hyperobject objlist view stream category 0 filter subobjects refvars link-printer) (when file-wrapper (fmt-file-end view stream)))