1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: View methods for Hyperobjects
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: views.lisp,v 1.50 2003/06/06 21:59:29 kevin Exp $
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package #:hyperobject)
18 (defclass object-view ()
19 ((object-class-name :initform nil :initarg :object-class-name
20 :accessor object-class-name
21 :documentation "Name of class of object to be viewed.")
22 (object-class :initform nil :initarg :object-class
23 :accessor object-class
24 :documentation "Class of object to be viewed.")
25 (slots :initform nil :initarg :slots :accessor slots
26 :documentation "List of effective slots for object to be viewed.")
27 (name :initform nil :initarg :name :accessor name
28 :documentation "Name for this view.")
29 (category :initform nil :initarg :category :accessor category
30 :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
31 (source-code :initform nil :initarg :source-code :accessor source-code
32 :documentation "Source code for generating view.")
33 (country-language :initform :en :initarg :country-language
34 :documentation "Country's Language for this view.")
36 (file-start-str :type (or string null) :initform nil :initarg :file-start-str
37 :accessor file-start-str)
38 (file-end-str :type (or string null) :initform nil :initarg :file-end-str
39 :accessor file-end-str)
40 (list-start-printer :type (or string function null) :initform nil
41 :initarg :list-start-printer
42 :accessor list-start-printer)
43 (list-start-indent :initform nil :initarg :list-start-indent
44 :accessor list-start-indent)
45 (list-end-printer :type (or string function null) :initform nil
46 :initarg :list-end-printer
47 :accessor list-end-printer)
48 (list-end-indent :initform nil :initarg :list-end-indent
49 :accessor list-end-indent)
50 (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
51 :accessor obj-start-printer)
52 (obj-start-indent :initform nil :initarg :obj-start-indent
53 :accessor obj-start-indent)
54 (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
55 :accessor obj-end-printer)
56 (obj-end-indent :initform nil :initarg :obj-end-indent
57 :accessor obj-end-indent)
58 (obj-data-indent :initform nil :initarg :obj-data-indent
59 :accessor obj-data-indent)
60 (obj-data-printer :type (or function null) :initform nil
61 :initarg :obj-data-printer
62 :accessor obj-data-printer)
63 (obj-data-print-code :type (or function null) :initform nil
64 :initarg :obj-data-print-code
65 :accessor obj-data-print-code)
66 (obj-data-end-str :type (or string null) :initform nil
67 :initarg :obj-data-end-str
68 :accessor obj-data-end-str)
69 (link-slots :type list :initform nil
70 :documentation "List of slot names that have hyperlinks"
72 (link-page-name :type (or string null) :initform nil :initarg :link-page-name
73 :accessor link-page-name)
74 (link-href-start :type (or string null) :initform nil :initarg :link-href-start
75 :accessor link-href-start)
76 (link-href-end :type (or string null) :initform nil :initarg :link-href-end
77 :accessor link-href-end)
78 (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
79 :accessor link-ampersand))
80 (:default-initargs :link-page-name "disp-func1")
81 (:documentation "View class for a hyperobject"))
84 (defun get-category-view (obj category &optional slots)
85 "Find or make a category view for an object"
86 (let ((obj-class (class-of obj)))
88 (default-view obj-class)
89 (aif (find category (views obj-class) :key #'category)
92 (make-instance 'object-view
93 :object-class-name (class-name obj-class)
94 :object-class obj-class
97 (push view (views obj-class))
100 ;;;; *************************************************************************
101 ;;;; Metaclass Intialization
102 ;;;; *************************************************************************
104 (defun finalize-views (cl)
105 "Finalize all views that are given on a objects initialization"
106 (unless (default-print-slots cl)
107 (setf (default-print-slots cl)
108 (mapcar #'slot-definition-name (class-slots cl))))
110 (dolist (view-def (views cl))
111 (push (make-object-view cl view-def) views))
112 (setf (views cl) (nreverse views)))
115 (setf (default-view cl) (make-object-view cl (default-view cl))))
117 (setf (default-view cl) (make-object-view cl (car (views cl)))))
119 (setf (default-view cl) (make-object-view cl :default)))))
121 (defun make-object-view (cl view-def)
122 "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
124 ((typep view-def 'object-view)
126 ((eq view-def :default)
127 (let* ((name (class-name cl))
128 (view (make-instance 'object-view :name "automatic"
129 :object-class-name name
131 :category :compact-text)))
134 (apply #'make-instance 'object-view view-def))
136 (error "Invalid parameter to make-object-view: ~S" view-def))))
138 (defmethod initialize-instance :after ((view object-view)
139 &rest initargs &key &allow-other-keys)
140 (initialize-view (object-class view) view))
142 (defun initialize-view (obj-cl view)
143 "Calculate all view slots for a hyperobject class"
146 (initialize-view-by-category obj-cl view))
148 (initialize-view-by-source-code obj-cl view))
150 (setf (category view) :compact-text)
151 (initialize-view-by-category obj-cl view))))
153 (defun initialize-view-by-source-code (obj-cl view)
154 "Initialize a view based upon a source code"
155 (let ((source-code (source-code view)))
156 (error "not implemented")
160 (defmacro write-simple (v s)
163 (write-string ,v ,s))
166 (excl::print-fixnum ,s 10 ,v))
168 (write-string (symbol-name ,v) ,s))
170 (write-string (write-to-string ,v) ,s))))
172 (defun write-ho-value (obj name type formatter cdata strm)
173 (declare (ignorable type))
174 (let* ((slot-data (slot-value obj name))
175 (fmt-data (if formatter
176 (funcall formatter slot-data)
179 (write-xml-cdata fmt-data strm)
180 (write-simple fmt-data strm))))
182 (defun ppfc-html (title name type formatter cdata print-func)
183 (vector-push-extend '(write-string "<span class=\"" s) print-func)
184 (vector-push-extend `(write-string ,title s) print-func)
185 (vector-push-extend '(write-string "\">" s) print-func)
186 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
187 (vector-push-extend '(write-string "</span>" s) print-func))
189 (defun ppfc-xml (tag name type formatter cdata print-func)
190 (vector-push-extend '(write-char #\< s) print-func)
191 (vector-push-extend `(write-string ,tag s) print-func)
192 (vector-push-extend '(write-char #\> s) print-func)
193 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
194 (vector-push-extend '(write-string "</" s) print-func)
195 (vector-push-extend `(write-string ,tag s) print-func)
196 (vector-push-extend '(write-char #\> s) print-func))
198 (defun ppfc-html-labels (label name type formatter cdata print-func)
199 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
200 (vector-push-extend `(write-string ,label s) print-func)
201 (vector-push-extend '(write-string "</span> " s) print-func)
202 (ppfc-html label name type formatter cdata print-func))
204 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
205 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
206 (vector-push-extend `(write-string ,label s) print-func)
207 (vector-push-extend '(write-string "</span> " s) print-func)
208 (ppfc-html tag name type formatter cdata print-func))
210 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
211 (vector-push-extend '(write-string "<label>" s) print-func)
212 (vector-push-extend `(write-string ,label s) print-func)
213 (vector-push-extend '(write-string "</label> " s) print-func)
214 (ppfc-xml tag name type formatter cdata print-func))
216 (defun ppfc-html-link (name type formatter cdata nlink print-func)
217 (declare (fixnum nlink))
218 (vector-push-extend '(write-char #\< s) print-func)
219 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
220 (vector-push-extend '(write-char #\> s) print-func)
221 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
222 (vector-push-extend '(write-string "</" s) print-func)
223 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
224 (vector-push-extend '(write-char #\> s) print-func))
226 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
227 (vector-push-extend '(write-string "<label>" s) print-func)
228 (vector-push-extend `(write-string ,label s) print-func)
229 (vector-push-extend '(write-string "</label> " s) print-func)
230 (ppfc-html-link name type formatter cdata nlink print-func))
232 (defun push-print-fun-code (category slot nlink print-func)
233 (let* ((formatter (esd-print-formatter slot))
234 (name (slot-definition-name slot))
235 (user-name (esd-user-name slot))
236 (xml-user-name (escape-xml-string user-name))
237 (xml-tag (escape-xml-string user-name))
238 (type (slot-value slot 'type))
240 (and (in category :xml :xhtml :xml-link :xhtml-link
241 :xml-labels :ie-xml-labels
242 :xhtml-link-labels :xml-link-labels :ie-xml-link
245 (lisp-type-is-a-string type))))))
246 (hyperlink (esd-hyperlink slot)))
251 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
252 (:compact-text-labels
253 (vector-push-extend `(write-string ,user-name s) print-func)
254 (vector-push-extend '(write-char #\space s) print-func)
256 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
258 (ppfc-html user-name name type formatter cdata print-func))
260 (ppfc-xml xml-tag name type formatter cdata print-func))
262 (ppfc-html-labels user-name name type formatter cdata print-func))
264 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
266 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
267 ((or :html-link :xhtml-link)
269 (ppfc-html-link name type formatter cdata nlink print-func)
270 (ppfc-html user-name name type formatter cdata print-func)))
271 ((or :xml-link :ie-xml-link)
273 (ppfc-html-link name type formatter cdata nlink print-func)
274 (ppfc-xml xml-tag name type formatter cdata print-func)))
277 (ppfc-html-link-labels user-name name type formatter cdata nlink
279 (ppfc-html-labels user-name name type formatter cdata print-func)))
282 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
284 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
286 ((or :xml-link-labels :ie-xml-link-labels)
288 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
290 (ppfc-xml-labels xml-tag user-name name type formatter cdata
294 (defun view-has-links-p (view)
295 (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
296 :html-link-labels :xhtml-link-labels :xml-link-labels
297 :ie-xml-link-labels))
299 (defun initialize-view-by-category (obj-cl view)
300 "Initialize a view based upon a preset category"
301 (unless (in (category view) :compact-text :compact-text-labels
302 :html :html-labels :html-link-labels
303 :xhtml :xhtml-labels :xhtml-link-labels
304 :xhtml-link :html-link
305 :xml :xml-labels :xml-link :ie-xml-link
306 :xml-link-labels :ie-xml-link-labels)
307 (error "Unknown view category ~A" (category view)))
309 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
312 (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
314 (do* ((slots (slots view) (cdr slots))
315 (slot-name (car slots) (car slots))
316 (slot (find-slot-by-name obj-cl slot-name)
317 (find-slot-by-name obj-cl slot-name)))
320 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
322 (push-print-fun-code (category view) slot (length links) print-func)
323 (when (> (length slots) 1)
324 (vector-push-extend '(write-char #\space s) print-func))
326 (when (and (view-has-links-p view) (esd-hyperlink slot))
327 (push (slot-definition-name slot) links)))
329 (vector-push-extend 'x print-func) ;; return object
330 (setf (obj-data-print-code view) `(lambda (x s links)
331 (declare (ignorable s links))
332 ,@(map 'list #'identity print-func)))
333 (setf (obj-data-printer view)
334 (compile nil (eval (obj-data-print-code view))))
336 (setf (link-slots view) (nreverse links)))
338 (finalize-view-by-category view)
341 (defun finalize-view-by-category (view)
342 (case (category view)
343 ((or :compact-text :compact-text-labels)
344 (initialize-text-view view))
345 ((or :html :xhtml :html-labels :xhtml-labels)
346 (initialize-html-view view))
347 ((or :xml :xml-labels)
348 (initialize-xml-view view))
349 ((or :html-link :html-link-labels)
350 (initialize-html-view view)
351 (setf (link-href-start view) "a href=")
352 (setf (link-href-end view) "a")
353 (setf (link-ampersand view) "&"))
354 ((or :xhtml-link :xhtml-link-labels)
355 (initialize-html-view view)
356 (setf (link-href-start view) "a href=")
357 (setf (link-href-end view) "a")
358 (setf (link-ampersand view) "&"))
359 ((or :xml-link :xml-link-labels)
360 (initialize-xml-view view)
361 (setf (link-href-start view)
362 "xmllink xlink:type=\"simple\" xlink:href=")
363 (setf (link-href-end view) "xmllink")
364 (setf (link-ampersand view) "&"))
365 ((or :ie-xml-link :ie-xml-link-labels)
366 (initialize-xml-view view)
367 (setf (link-href-start view) "html:a href=")
368 (setf (link-href-end view) "html:a")
369 (setf (link-ampersand view) "&"))))
372 ;;;; *************************************************************************
373 ;;;; View Data Format Section
374 ;;;; *************************************************************************
376 (defun class-name-of (obj)
377 (string-downcase (class-name (class-of obj))))
379 (defvar +newline-string+ (format nil "~%"))
381 (defun write-user-name-maybe-plural (obj nitems strm)
384 (hyperobject-class-user-name-plural obj)
385 (hyperobject-class-user-name obj))
388 (defun initialize-text-view (view)
389 (setf (list-start-printer view)
391 (eval '(lambda (obj nitems strm)
392 (write-user-name-maybe-plural obj nitems strm)
393 (write-char #\: strm)
394 (write-char #\Newline strm)))))
395 (setf (list-start-indent view) t)
396 (setf (obj-data-indent view) t)
397 (setf (obj-data-end-str view) +newline-string+))
399 (defun html-list-start-func (obj nitems strm)
400 (write-string "<p><b>" strm)
401 (write-user-name-maybe-plural obj nitems strm)
402 (write-string ":</b></p><div class=\"" strm)
403 (write-string (class-name-of obj) strm)
404 (write-string "\"><ul>" strm)
405 (write-char #\newline strm))
407 (defun initialize-html-view (view)
408 (initialize-text-view view)
409 (setf (file-start-str view) (format nil "<html><body>~%"))
410 (setf (file-end-str view) (format nil "</body><html>~%"))
411 (setf (list-start-indent view) t)
412 (setf (list-start-printer view) #'html-list-start-func)
413 (setf (list-end-printer view) (format nil "</ul></div>~%"))
414 (setf (list-end-indent view) t)
415 (setf (obj-start-indent view) t)
416 (setf (obj-start-printer view) "<li>")
417 (setf (obj-end-indent view) t)
418 (setf (obj-end-printer view) (format nil "</li>~%"))
419 (setf (obj-data-indent view) nil))
421 (defun initialize-xhtml-view (view)
422 (initialize-text-view view)
423 (setf (file-start-str view) (format nil "<html><body>~%"))
424 (setf (file-end-str view) (format nil "</body><html>~%"))
425 (setf (list-start-indent view) t)
426 (setf (list-start-printer view) #'html-list-start-func)
427 (setf (list-end-printer view) (format nil "</ul></div>~%"))
428 (setf (list-end-indent view) t)
429 (setf (obj-start-indent view) t)
430 (setf (obj-start-printer view) "<li>")
431 (setf (obj-end-indent view) t)
432 (setf (obj-end-printer view) (format nil "</li>~%"))
433 (setf (obj-data-indent view) nil))
435 (defun xmlformat-list-end-func (x strm)
436 (write-string "</" strm)
437 (write-string (class-name-of x) strm)
438 (write-string "list" strm)
439 (write-string ">" strm)
440 (write-char #\newline strm))
442 (defun xmlformat-list-start-func (x nitems strm)
443 (write-char #\< strm)
444 (write-string (class-name-of x) strm)
445 (write-string "list><title>" strm)
446 (write-user-name-maybe-plural x nitems strm)
447 (write-string ":</title>" strm)
448 (write-char #\newline strm))
450 (defun initialize-xml-view (view)
451 (initialize-text-view view)
452 (setf (file-start-str view) "") ; (std-xml-header)
453 (setf (list-start-indent view) t)
454 (setf (list-start-printer view) #'xmlformat-list-start-func)
455 (setf (list-end-indent view) t)
456 (setf (list-end-printer view) #'xmlformat-list-end-func)
457 (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view)))
458 (setf (obj-start-indent view) t)
459 (setf (obj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
460 (setf (obj-end-indent view) nil)
461 (setf (obj-data-indent view) nil))
464 ;;; File Start and Ends
466 (defun fmt-file-start (view strm)
467 (awhen (file-start-str view)
468 (write-string it strm)))
470 (defun fmt-file-end (view strm)
471 (awhen (file-end-str view)
472 (write-string it strm)))
474 ;;; List Start and Ends
476 (defun fmt-list-start (obj view strm indent num-items)
477 (when (list-start-indent view)
478 (indent-spaces indent strm))
479 (awhen (list-start-printer view)
481 (write-string it strm)
482 (funcall it obj num-items strm))))
484 (defun fmt-list-end (obj view strm indent num-items)
485 (declare (ignore num-items))
486 (when (list-end-indent view)
487 (indent-spaces indent strm))
488 (awhen (list-end-printer view)
490 (write-string it strm)
491 (funcall it obj strm))))
493 ;;; Object Start and Ends
495 (defun fmt-obj-start (obj view strm indent)
496 (when (obj-start-indent view)
497 (indent-spaces indent strm))
498 (awhen (obj-start-printer view)
500 (write-string it strm)
501 (funcall it obj strm))))
503 (defun fmt-obj-end (obj view strm indent)
504 (when (obj-end-indent view)
505 (indent-spaces indent strm))
506 (awhen (obj-end-printer view)
508 (write-string it strm)
509 (funcall it obj strm))))
514 (defun make-link-start (view fieldfunc fieldvalue refvars)
515 (with-output-to-string (s)
516 (write-string (link-href-start view) s)
518 (write-string (make-url (link-page-name view)) s)
519 (write-string "?func=" s)
520 (write-simple fieldfunc s)
521 (write-string (link-ampersand view) s)
522 (write-string "key=" s)
523 (write-simple fieldvalue s)
524 (dolist (var refvars)
525 (write-string (link-ampersand view) s)
526 (write-simple (car var) s)
528 (write-simple (cdr var) s))
531 (defun make-link-end (obj view fieldname)
532 (declare (ignore obj fieldname))
533 (link-href-end view))
535 (defun fmt-obj-data (obj view strm indent refvars)
536 (when (obj-data-indent view)
537 (indent-spaces indent strm))
538 (if (link-slots view)
539 (fmt-obj-data-with-link obj view strm refvars)
540 (fmt-obj-data-plain obj view strm))
541 (awhen (obj-data-end-str view)
542 (write-string it strm)))
544 (defun fmt-obj-data-plain (obj view strm)
545 (awhen (obj-data-printer view)
546 (funcall it obj strm nil)))
548 (defun fmt-obj-data-with-link (obj view strm refvars)
549 (let ((refvalues '()))
550 ;; make list of hyperlink link fields for printing to refstr template
551 (dolist (name (link-slots view))
552 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
553 (push (make-link-start view (lookup it) (slot-value obj name)
554 (append (link-parameters it) refvars))
556 (push (make-link-end obj view name) refvalues)))
557 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
559 (defun obj-data (obj view)
560 "Returns the objects data as a string. Used by common-graphics outline function"
561 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
563 ;;; Display method for objects
566 (defun load-all-subobjects (objs)
567 "Load all subobjects if they have not already been loaded."
568 (dolist (obj (mklist objs))
569 (dolist (subobj (hyperobject-class-subobjects obj))
570 (awhen (slot-value obj (name-slot subobj))
571 (load-all-subobjects it))))
574 (defun view-hyperobject (objs view category strm &optional (indent 0) filter
576 "Display a single or list of hyperobject-class instances and their subobjects"
577 (declare (fixnum indent))
578 (let-when (objlist (mklist objs))
579 (let ((nobjs (length objlist))
583 (*print-readably* nil)
586 (fmt-list-start (car objlist) view strm indent nobjs)
587 (dolist (obj objlist)
588 (unless (and filter (not (funcall filter obj)))
589 (fmt-obj-start obj view strm indent)
590 (fmt-obj-data obj view strm (1+ indent) refvars)
591 (when (and subobjects (hyperobject-class-subobjects obj))
592 (dolist (subobj (hyperobject-class-subobjects obj))
593 (aif (slot-value obj (name-slot subobj))
594 (view-hyperobject it (get-category-view (car (mklist it)) category)
595 category strm (1+ indent) filter
596 subobjects refvars))))
597 (fmt-obj-end obj view strm indent)))
598 (fmt-list-end (car objlist) view strm indent nobjs)))
602 (defun view (objs &key (stream *standard-output*) category view
603 filter subobjects refvars file-wrapper)
604 "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
605 (let-when (objlist (mklist objs))
607 (setq view (get-category-view (car objlist) category)))
609 (setq view (default-view (class-of (car objlist)))))
611 (fmt-file-start view stream))
612 (view-hyperobject objlist view category stream 0 filter subobjects refvars)
614 (fmt-file-end view stream)))
620 (defun fmt-comma-integer (i)
621 (format nil "~:d" i))