- (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))
+ (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 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-name (class-name 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))