+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
+
+(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
+ :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.")
+ (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 (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-str-or-func :type (or string function null) :initform nil
+ :initarg :list-start-str-or-func
+ :accessor list-start-str-or-func)
+ (list-start-indent :initform nil :initarg :list-start-indent
+ :accessor list-start-indent)
+ (list-end-str-or-func :type (or string function null) :initform nil
+ :initarg :list-end-str-or-func
+ :accessor list-end-str-or-func)
+ (list-end-indent :initform nil :initarg :list-end-indent
+ :accessor list-end-indent)
+ (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func
+ :accessor obj-start-str-or-func)
+ (obj-start-indent :initform nil :initarg :obj-start-indent
+ :accessor obj-start-indent)
+ (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func
+ :accessor obj-end-str-or-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-func :type (or function null) :initform nil
+ :initarg :obj-data-func
+ :accessor obj-data-func)
+ (obj-data-print-code :type (or function null) :initform nil
+ :initarg :obj-data-print-code
+ :accessor obj-data-print-code)
+ (obj-data-end-str :type (or string null) :initform nil
+ :initarg :obj-data-end-str
+ :accessor obj-data-end-str)
+ (link-slots :type list :initform nil
+ :documentation "List of slot names that have hyperlinks"
+ :accessor link-slots)
+ (link-page-name :type (or string null) :initform nil :initarg :link-page-name
+ :accessor link-page-name)
+ (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-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-name (class-name obj-class)
+ :object-class obj-class
+ :category category
+ :slots slots)))
+ (push view (views obj-class))
+ 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))))
+ (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 name
+ :object-class cl
+ :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 (object-class view) view))
+
+(defun initialize-view (obj-cl 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)
+ "Initialize a view based upon a source code"
+ (let ((source-code (source-code view)))
+ (error "not implemented")
+ )
+ )
+
+(defmacro write-simple (v s)
+ `(typecase ,v
+ (string
+ (write-string ,v ,s))
+ #+allegro
+ (fixnum
+ (excl::print-fixnum ,s 10 ,v))
+ (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))
+ (data (if cdata
+ (kmrcl:xml-cdata fmt-data)
+ fmt-data)))
+ (write-simple data strm)))
+
+
+(defun ppfc-html (title name type formatter cdata print-func)
+ (vector-push-extend '(write-string "<span class=\"" s) print-func)
+ (vector-push-extend `(write-string ,title s) 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 "</span>" 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 "<span class=\"label\">" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</span> " 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 "<span class=\"label\">" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</span> " 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 "<label>" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</label> " 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 "<label>" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</label> " s) print-func)
+ (ppfc-html-link name type formatter cdata nlink print-func))
+
+(defun push-print-fun-code (category slot nlink print-func)
+ (let* ((formatter (esd-print-formatter slot))
+ (name (slot-definition-name slot))
+ (namestr-lower (string-downcase (symbol-name name)))
+ (xml-namestr (escape-xml-string namestr-lower))
+ (xml-tag (escape-xml-string namestr-lower))
+ (type (slot-value slot 'type))
+ (cdata (not (null
+ (and (in category :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 category
+ (:compact-text
+ (vector-push-extend
+ `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+ (:compact-text-labels
+ (vector-push-extend `(write-string ,namestr-lower 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 namestr-lower name type formatter cdata print-func))
+ (:xml
+ (ppfc-xml xml-tag name type formatter cdata print-func))
+ (:html-labels
+ (ppfc-html-labels namestr-lower name type formatter cdata print-func))
+ (:xhtml-labels
+ (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func))
+ (:xml-labels
+ (ppfc-xml-labels xml-namestr 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 namestr-lower 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 namestr-lower name type formatter cdata nlink
+ print-func)
+ (ppfc-html-labels namestr-lower name type formatter cdata print-func)))
+ (:xhtml-link-labels
+ (if hyperlink
+ (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+ print-func)
+ (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata
+ print-func)))
+ ((or :xml-link-labels :ie-xml-link-labels)
+ (if hyperlink
+ (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+ print-func)
+ (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata
+ print-func))))))
+
+
+(defun view-has-links-p (view)
+ (in (category 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)
+ (error "Unknown view category ~A" (category view)))