New HTML style features for tables

[Christopher Browne]

On Thu, 22 Mar 2001 19:17:45 PST, the world broke into rejoicing as
Christian Stimming <stimming@uclink.berkeley.edu>  said:
> I have a question on how to use the HTML style features. I would like to 
> have a table cell style grand-total as described below, but I would like 
> to have it markup the cell content in boldface. How do I specify that one 
> semantic tags (grand-total) gets rendered to several HTML tags 
> (<td><b>...)? Or did I misunderstand the intended usage of the stylesheets?
> 
> Christian
> 
> On Friday 09 March 2001 08:09, Bill Gribble wrote:
> > Dave: after our IRC discussion I added a few new things to the
> > html-table API to allow reports to assign semantic tags like "total",
> > "subtotal", "summary-row" etc to table cells and rows 
> >
> > For example, if you want all "grand-total" table
> > cells to be rendered with a background color of 0xff00ff, you'd put
> > this in the style sheet definition:
> >
> >   (gnc:html-style-sheet-set-style!
> >    ss "grand-total"
> >    'tag "td"
> >    'attribute (list "bgcolor" "0xff00ff"))

It would seem that the following _should_ work:
   (gnc:html-style-sheet-set-style!
    ss "grand-total"
    'tag (list "td" "b")
    'attribute (list "bgcolor" "0xff00ff"))

This would be expected to generate the following:

<td> <b>
  ...stuff omitted...
</b> </td>

Change html-document.scm, replacing functions as follows:

(define (gnc:html-document-markup-start doc markup . rest)
  (let ((childinfo (gnc:html-document-fetch-markup-style doc markup))
        (extra-attrib 
         (if (not (null? rest))
             rest #f))
        (show-result #f))
    ;; now generate the start tag
    (let ((tag   (gnc:html-markup-style-info-tag childinfo))
          (attr  (gnc:html-markup-style-info-attributes childinfo))
          (face  (gnc:html-markup-style-info-font-face childinfo))
          (size  (gnc:html-markup-style-info-font-size childinfo))
          (color (gnc:html-markup-style-info-font-color childinfo)))
      
      ;; "" tags mean "show no tag"; #f tags means use default.
      (cond ((not tag)
             (set! tag markup))
            ((string=? tag "")
             (set! tag #f)))
      (let* ((retval '())
             (push (lambda (l) (set! retval (cons l retval))))
	     (add-internal-tag (lambda (t) (push "<") (push tag) (push ">")))
	     (add-attribute
	      (lambda (key value prior) (push " ") (push key) (push "=")
		      (push value) #t))
	     (addextraatt
	      (lambda (attr)
		(cond ((string? attr) (push " ") (push attr))
		      (attr (gnc:warn "non-string attribute" attr)))))
	     (build-first-tag
	      (lambda (tag)
		(push "\n<") (push tag)
		(if attr (hash-fold add-attribute #f attr))
		(if extra-attrib (for-each addextraatt extra-attrib))
		(push ">"))))
        (if tag
	    (if (list? tag)
		(begin 
		  (build-first-tag (car tag))
		  (for-each add-internal-tag (cdr tag)))
		(build-first-tag tag)))
;        (if tag
;            (begin 
;              (push "\n<")
;              (push tag)
;              (if attr
;                  (hash-fold 
;                   (lambda (key value prior)
;                     (push " ") (push key) (push "=")
;                     (push value)
;                     #t)
;                   #f
;                   attr))
;              (if extra-attrib
;                  (for-each
;                   (lambda (attr)
;                     (cond ((string? attr) (push " ") (push attr))
;                           (attr (gnc:warn "non-string attribute" attr))))
;                   extra-attrib))
;              (push ">")))
	(if (or face size color)
            (begin 
              (push "<font ")
              (if face
                  (begin 
                    (push "face=\"") (push face) (push "\" ")))
              (if size
                  (begin 
                    (push "size=\"") (push size) (push "\" ")))
              (if color
                  (begin 
                    (push "color=\"") (push color) (push "\" ")))
              (push ">")))
        retval))))

(define (gnc:html-document-markup-end doc markup)
  (let ((childinfo  (gnc:html-document-fetch-markup-style doc markup)))
    ;; now generate the end tag
    (let ((tag   (gnc:html-markup-style-info-tag childinfo))
          (closing-font-tag
	   (gnc:html-markup-style-info-closing-font-tag childinfo)))
      ;; "" tags mean "show no tag"; #f tags means use default.
      (cond ((not tag)
             (set! tag markup))
            ((string=? tag "")
             (set! tag #f)))
      (let* ((retval '())
             (push (lambda (l) (set! retval (cons l retval)))))
        (if closing-font-tag
            (push "</font>\n"))
;        (if tag 
;            (begin 
;              (push "</")
;              (push tag)
;              ;; newline after every close tag... just temporary
;              (push ">\n")))
	(if tag
	    (let ((addtag (lambda (t)
			    (push "</")
			    (push tag)
			    (push ">\n"))))
	      (cond
	       ((string? tag) 
		(addtag tag))
	       ((list? tag)
		(for-each addtag (reverse tag))))))
        retval))))

Note that I haven't tried this out at all; your milage may vary...
--
(reverse (concatenate 'string "gro.mca@" "enworbbc"))
http://www.ntlug.org/~cbbrowne/internet.html
MS-Windows: Proof that P.T. Barnum was correct.