- (format nil "Hyperobject~A~A~A~A"
- (aif (slot-value cl 'title)
- (format nil ": ~A" it ""))
- (aif (slot-value cl 'description)
- (format nil "~%Class description: ~A" it) "")
- (aif (slot-value cl 'subobjects)
- (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
- (aif (slot-value cl 'print-slots)
- (format nil "~%Print-slots:~{ ~A~}" it) "")
- ))))
-
-(defun process-views (cl)
- "Calculate all view slots for a hyperobject class"
- (let ((fmtstr-text "")
- (fmtstr-html "")
- (fmtstr-xml "")
- (fmtstr-text-labels "")
- (fmtstr-html-labels "")
- (fmtstr-xml-labels "")
- (fmtstr-html-ref "")
- (fmtstr-xml-ref "")
- (fmtstr-html-ref-labels "")
- (fmtstr-xml-ref-labels "")
- (first-field t)
- (value-func '())
- (xmlvalue-func '())
- (classname (class-name cl))
- (package (symbol-package (class-name cl)))
- (references nil))
- (declare (ignore classname))
- (check-type (slot-value cl 'print-slots) list)
- (dolist (slot-name (slot-value cl 'print-slots))
- (let ((slot (find-slot-by-name cl slot-name)))
- (unless slot
- (error "Slot ~A is not found in class ~S" slot-name cl))
- (let ((name (slot-definition-name slot))
- (namestr (symbol-name (slot-definition-name slot)))
- (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
- (type (slot-value slot 'ho-type))
- (print-formatter (slot-value slot 'print-formatter))
- (value-fmt "~a")
- (plain-value-func nil)
- html-str xml-str html-label-str xml-label-str)
-
- (when (or (eql type :integer) (eql type :fixnum))
- (setq value-fmt "~d"))
-
- (when (eql type :boolean)
- (setq value-fmt "~a"))
-
- (if first-field
- (setq first-field nil)
- (progn
- (string-append fmtstr-text " ")
- (string-append fmtstr-html " ")
- (string-append fmtstr-xml " ")
- (string-append fmtstr-text-labels " ")
- (string-append fmtstr-html-labels " ")
- (string-append fmtstr-xml-labels " ")
- (string-append fmtstr-html-ref " ")
- (string-append fmtstr-xml-ref " ")
- (string-append fmtstr-html-ref-labels " ")
- (string-append fmtstr-xml-ref-labels " ")))
-
- (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
- (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
- (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
- (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-
- (string-append fmtstr-text value-fmt)
- (string-append fmtstr-html html-str)
- (string-append fmtstr-xml xml-str)
- (string-append fmtstr-text-labels namestr-lower " " value-fmt)
- (string-append fmtstr-html-labels html-label-str)
- (string-append fmtstr-xml-labels xml-label-str)
-
- (if (slot-value slot 'reference)
- (progn
- (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
- (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
- (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
- (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
- (push (make-instance 'reference :name name
- :lookup (slot-value slot 'reference))
- references))
- (progn
- (string-append fmtstr-html-ref html-str)
- (string-append fmtstr-xml-ref xml-str)
- (string-append fmtstr-html-ref-labels html-label-str)
- (string-append fmtstr-xml-ref-labels xml-label-str)))
-
- (if print-formatter
- (setq plain-value-func
- (list `(,print-formatter (slot-value x ',(intern namestr package)))))
- (setq plain-value-func
- (list `(slot-value x ',(intern namestr package)))))
- (setq value-func (append value-func plain-value-func))
-
- (if (eql type :cdata)
- (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
- (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
- )))
-
- (setf (slot-value cl 'references) references)
-
- (if value-func
- (setq value-func `(lambda (x) (values ,@value-func)))
- (setq value-func `(lambda () (values))))
- (setq value-func (compile nil (eval value-func)))
-
- (if xmlvalue-func
- (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
- (setq xmlvalue-func `(lambda () (values))))
- (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
-
- (setf (slot-value cl 'fmtstr-text) fmtstr-text)
- (setf (slot-value cl 'fmtstr-html) fmtstr-html)
- (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
- (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
- (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
- (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
- (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
- (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
- (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
- (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
- (setf (slot-value cl 'value-func) value-func)
- (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
- (values))
+ (format nil "Hyperobject~A~A~A~A"
+ (aif (user-name cl)
+ (format nil ": ~A" it ""))
+ (aif (description cl)
+ (format nil "~%Class description: ~A" it) "")
+ (aif (subobjects cl)
+ (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
+ (aif (default-print-slots cl)
+ (format nil "~%Default print slots:~{ ~A~}" it) "")
+ ))))
+
+(defun finalize-hyperlinks (cl)
+ (let ((hyperlinks '()))
+ (dolist (esd (class-slots cl))
+ (awhen (slot-value esd 'hyperlink)
+ (push
+ (make-instance 'hyperlink
+ :name (slot-definition-name esd)
+ :lookup it
+ :link-parameters (slot-value esd 'hyperlink-parameters))
+ hyperlinks)))
+ ;; cmu/sbcl reverse class-slots compared to the defclass form
+ ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu
+ #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks))
+ (setf (slot-value cl 'hyperlinks) hyperlinks)))