Patch to SCM Stuff...

Christopher Browne cbbrowne@hex.net
Mon, 14 Aug 2000 23:19:12 -0500


Unfortunately, I'm having _zero_ luck connecting to cvs.gnucash.org,
so I'm depending on local RCS differences to find the changes to be
made.

The "global" change is that rather than using (string-append) to 
create the output, I've changed the (html-whatever) functions to instead
create lists.

Thus rather than:
(define (html-strong html) 
   (if html 
       (string-append "<strong>" html "</strong>") #f))
we get:
(define (html-strong html)
   (if html
       (list "<strong>" html "</strong>") #f))

Net result of this is that rather than generating a single string,
you wind up with a tree.

This means that rather than turning this into a string basically
by appending the strings together, via (report-output->string lines),
there is a tree-walker:
  (define (output-tree-to-port tree port)
    (cond
      ((pair? tree)
       (output-tree-to-port (car tree) port)
       (output-tree-to-port (cdr tree) port))
      ((string? tree)
       (display-report-list-item tree port))
      (tree
       (display-report-list-item "<B> Error! bad-atom! </B>" port)
       (display-report-list-item tree port))))

What I'd _rather_ see, a bit longer term, is to use the XML generator
to generate HTML output.

A (very simple) table might be generated via:

(define simple-table
  (xml-element 'table '(border 1)
    (xml-element 'tr #f
      (xml-element 'th #f "ISO Code")
      (xml-element 'th #f "Country"))
    (xml-element 'tr #f
      (xml-element 'td #f "USD")
      (xml-element 'td #f "US Dollars"))
    (xml-element 'tr #f
      (xml-element 'td #f "CDN")
      (xml-element 'td #f "Canadian Dollars"))
    (xml-element 'tr #f
      (xml-element 'td #f "UKP")
      (xml-element 'td #f "UK Pounds"))))

and would turn into well-formed HTML via:

(output-xml-element simple-table port)

The benefits of this are fivefold:
  a) Many pieces of this can represent shared data; 'td does
     not exist 12 times, as it would if the string "td" were used, but
     rather exists exactly _once_.  This should be a pretty big deal.
  b) You have better guarantees of well-formedness, and don't need
     to track end tags and the likes.
  c) As a tree, the _pieces_ stay distinct until they are actually
     rendered, and the pieces can remain interpretable as complex
     substructures.  You could, for instance, choose to process a 
     particular subtree, and skip over others.  That would require
     nasty parsing in a 'string-oriented' representation.
  d) It's possible to do lazy evaluation; rather than evaluating this
     whole thing at once, much of it may be able to be generated on
     demand.  The lines of the table might not exist until the moment
     before they're outputted as strings to the port.
  e) What you essentially wind up with is an HTML "parse tree," and as
     it is stored in a parsed form, it becomes a whopping lot more 
     practical to write code that interprets it in some other way.
     The "trivial" mapping is to take the resulting list:
	(define simple-table
	  '(table (border 1)
	    (tr #f
	      (th #f "ISO Code")
	      (th #f "Country"))
	    (tr #f
	      (td #f "USD")
	      (td #f "US Dollars"))
	    (tr #f
	      (td #f "CDN")
	      (td #f "Canadian Dollars"))
	    (tr #f
	      (td #f "UKP")
	      (td #f "UK Pounds"))))
     
     and walk it, generating HTML tags for all the symbols and strings.

     The next step would be to walk the tree and generate a Gnumeric
     spreadsheet or a text output file.   I wouldn't want to _think_
     about doing this with raw HTML; it is _conceivable_ with the
     tree representation.

This first patch sort of goes "half way," bringing us at least to
the point of generating lists to provide the start of hierarchy...

--- cut here ---
---> This changes stuff in gnucash/src/scm...
--- html-generator.scm	2000/08/11 01:49:10	1.1
+++ html-generator.scm	2000/08/15 03:15:38
@@ -20,7 +20,6 @@
 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
 
 (gnc:support "html-generator.scm")
-
  
 ;; How this mechanism works:
 ;;
@@ -50,7 +49,6 @@
 ;; to the spec list that sets html-proc to #f, but sets
 ;; total-html-proc and subtotal-html-proc.  This way, subtotals really
 ;; stand out.
-;;
 ;; 
 ;; report-spec-structure 
 ;;  header: string describing the column
@@ -66,6 +64,13 @@
 ;;                         style chosen.
 ;;  subs-list-proc: a procedure that returns a list of subentry values
 ;;  subentry-html-proc: converts a subentry value into html
+
+(define NBSP "&nbsp;")  ;;; Non-breaking space
+;;; <http://www.sightspecific.com/~mosh/WWW_FAQ/nbsp.html>
+;;; Primarily "correctly" used in order to put _something_ into an
+;;; otherwise blank table cell because some web browsers do not cope
+;;; well with truly empty table cells
+
 (define report-spec-structure
   (make-record-type
    "report-spec-structure"
@@ -386,30 +391,41 @@
 (define html-table-group-color "#f6ffdb")
 
 (define (html-table-row-group row)
-  (if (string=? html-table-group-color "#f6ffdb")
-      (set! html-table-group-color "#ffffff")
-      (set! html-table-group-color "#f6ffdb"))
+  (set! html-table-group-color 
+	(if (string=? html-table-group-color "#f6ffdb")
+	    "#ffffff"
+	    "#f6ffdb"))
   row)
 
-(define (html-strong html)
+(define (string-html-strong html)
   (if html 
       (string-append "<STRONG>" html "</STRONG>")
       #f))
 
+(define (html-strong html)
+  (if html 
+      (list "<STRONG>" html "</STRONG>")
+      #f))
+
 (define (html-make-strong proc)
   (lambda (val)
     (html-strong (proc val))))
 
-(define (html-ital html)
+(define (string-html-ital html)
   (if html
       (string-append  "<i>"  html "</i>")
       #f))
 
+(define (html-ital html)
+  (if html
+      (list "<I>" html "</I>")
+      #f))
+
 (define (html-make-ital proc)
   (lambda (val)
     (html-ital (proc val))))
 
-(define (html-currency amount)
+(define (string-html-currency amount)
   (if amount
       (string-append
        "<font face=\"Courier\""
@@ -425,9 +441,36 @@
        "</font>")
       #f))
 
+(define (html-font-and-color face color contents)
+  (list
+   "<font"
+   (if face
+       (list "face=\"" face "\"")
+       #f)
+   (if color
+       (list "color=#" color)
+       #f)
+   ">"
+   contents
+   "</font>"))
+
+(define (html-currency amount)
+  (if amount
+      (let* 
+	  ((neg (< amount 0))
+	   (absamt (if neg (- amount) amount))
+	   (color (if neg "ff0000" #f))
+	   (prefix (if neg "(" NBSP))
+	   (suffix (if neg ")" NBSP))
+	   (displayamt (gnc:amount->string absamt #f #t #f)))
+	
+	(html-font-and-color "Courier" color
+			     (list prefix displayamt suffix)))
+      #f)
+
 (define (html-left-cell item)
   (if item
-      (string-append "<TD>" item "</TD>")
+      (html-table-col-align item #f)
       #f))
 
 (define (html-make-left-cell proc)
@@ -436,27 +479,32 @@
 
 (define (html-right-cell item)
   (if item
-      (string-append "<TD align=right>" item "</TD>")
+      (html-table-col-align item "right")
       #f))
 
 (define html-blank-cell
-  "<TD></TD>")
+  (list "<TD>" NBSP "</TD>"))
 
 (define (html-make-right-cell proc)
   (lambda (val)
     (html-right-cell (proc val))))
 
-(define (html-header-cell item)
+(define (string-html-header-cell item)
   (string-append "<TH justify=left>" item "</TH>"))
 
+(define (html-header-cell item)
+  (html-table-headcol-justified val "left"))
+
 (define (html-string string)
   (if string string #f))
 
 (define (html-number format number)
   (if number (sprintf #f format number) #f))
 
-(define (html-para text)
+(define (string-html-para text)
   (string-append "<P>" text "</P>\n"))
+(define (html-para text)
+  (list "<P>" text "</P>\n"))
 
 (define (html-start-document-title title color)
   (list 
@@ -465,11 +513,11 @@
    "<TITLE>" title "</TITLE>"
    "</HEAD>"
    (if color
-       (string-append "<BODY bgcolor=" color ">")
+       (list "<BODY bgcolor=" color ">")
        "<BODY>")))
 
 (define (html-start-document-color color)
-  (list 
+  (list
    "<HTML>"
    "<BODY bgcolor=" color ">"))
 
@@ -505,13 +553,21 @@
 
 ; Create a column entry
 (define (html-table-col val)
-  (string-append "<TD align=right>" (tostring val) "</TD>"))
+  (html-table-col-align "right" val))
 
-(define (html-table-col-align val align)
+(define (string-html-table-col-align val align)
   (string-append "<TD align=" align ">" (tostring val) "</TD>"))
 
+(define (html-table-col-align val align)
+  (list "<TD"
+	(if align
+	    (list "align=" align)
+	    #f)
+	">" 
+	(tostring val) "</TD>"))
+
 ; Create an html table row from a list of entries
-(define (html-table-row lst)
+(define (string-html-table-row lst)
   (cond ((string? lst) lst)
 	(else
 	 (string-append
@@ -519,8 +575,15 @@
 	  (apply string-append (map html-table-col lst))
 	  "</TR>"))))
 
+(define (html-table-row lst)
+  (if (string? lst)
+      lst
+      (list "<TR>"
+	    (map html-table-col lst)
+	    "</TR>")))
+
 ; Create an html table row from a list of entries
-(define (html-table-row-align lst align-list)
+(define (string-html-table-row-align lst align-list)
   (cond ((string? lst) lst)
 	(else
 	 (string-append
@@ -528,24 +591,57 @@
 	  (apply string-append (map html-table-col-align lst align-list))
 	  "</TR>"))))
 
+(define (html-table-row-with-align lst align-list)
+  (if (string? lst) 
+      lst
+      (list "<TR>"
+	    (map html-table-col-align lst align-list)
+	    "</TR>")))
+
 ; Create an html table from a list of rows, each containing 
 ;   a list of column entries
-(define (html-table caption hdrlst llst)
+(define (string-html-table caption hdrlst llst)
   (string-append
    (html-table-header caption hdrlst)
    (apply string-append (map html-table-row llst))
    (html-table-footer)))
 
-(define (html-table-headcol val)
+(define (html-table caption hdrlst llst)
+  (list
+   (html-table-header caption hdrlst)
+   (map html-table-row llst)
+   (html-table-footer)))
+
+(define (string-html-table-headcol val)
   (string-append "<TH justify=center>" (tostring val) "</TH>"))
 
-(define (html-table-header caption vec)
+(define (html-table-headcol-justified val justification)
+  (list "<TH"
+	(if justification
+	    (list "justify=" justification)
+	    #f)
+	">"
+	(tostring val)
+	"</TH">))
+
+(define (html-table-headcol val)
+  (html-table-headcol-justified val "center"))
+
+(define (string-html-table-header caption vec)
    (apply string-append
           "<TABLE cellspacing=10 rules=\"rows\">\n"
           (if caption
               (string-append "<caption><b>" caption "</b></caption>")
               "")
           (map html-table-headcol vec)))
+
+(define (html-table-header caption vec)
+   (list
+    "<TABLE cellspacing=10 rules=\"rows\">\n"
+    (if caption
+	(list "<caption><b>" caption "</b></caption>")
+	"")
+    (map html-table-headcol vec)))
 
 (define (html-table-footer)
   "</TABLE>")
--- report-utilities.scm	2000/08/11 01:49:10	1.1
+++ report-utilities.scm	2000/08/15 03:15:16
@@ -60,10 +60,9 @@
 		 (gnc:account-get-parent account)))))
 	  (if (string=? parent-name "")
 	      (gnc:account-get-name account)
-	      (string-append
-	       parent-name
-	       separator
-	       (gnc:account-get-name account)))))))
+	      (string-append parent-name
+			     separator
+			     (gnc:account-get-name account)))))))
 
 ;; returns a list contains elements of the-list for which predicate is true
 (define (gnc:filter-list the-list predicate)
--- report.scm	2000/08/11 01:49:10	1.1
+++ report.scm	2000/08/15 03:19:30
@@ -45,13 +45,36 @@
                         item))
      (else (gnc:warn "gnc:run-report - " item " is the wrong type."))))
 
-  (define (report-output->string lines)
+;; Old version assumed flat lists
+;   (define (report-output->string lines)
+;     (call-with-output-string
+;      (lambda (port)
+;        (for-each
+;         (lambda (item) (display-report-list-item item port))
+;         lines))))
+
+;; New version that processes a _tree_ rather than a flat list of
+;; strings.  This means that we can pass in somewhat "more structured"
+;; data.
+
+  (define (output-tree-to-port tree port)
+    (cond 
+     ((pair? tree)
+      (tree-to-port (car tree) port) 
+      (tree-to-port (cdr tree) port))
+     ((string? tree)
+      (display-report-list-item tree port)
+      (newline port))
+     (tree  ;;; If it's not #f
+      (display-report-list-item "<B> Error - Bad atom! </b>" port)
+      (display-report-list-item tree port)
+      (newline port))))
+  
+  (define (report-output->string tree)
     (call-with-output-string
      (lambda (port)
-       (for-each
-        (lambda (item) (display-report-list-item item port))
-        lines))))
-
+       (output-tree-to-port tree port))))
+  
   (let ((report (hash-ref *gnc:_report-info_* report-name)))
     (if report
         (let* ((renderer (gnc:report-renderer report))
@@ -61,7 +84,6 @@
         #f)))
 
 (define (gnc:report-menu-setup win)
-
   (define menu (gnc:make-menu "_Reports" (list "_Accounts")))
   (define menu-namer (gnc:new-menu-namer))
 
--
aa454@freenet.carleton.ca - <http://www.ntlug.org/~cbbrowne/linux.html>
Rules of the Evil Overlord #95. "My dungeon will have its own
qualified medical staff complete with bodyguards. That way if a
prisoner becomes sick and his cellmate tells the guard it's an
emergency, the guard will fetch a trauma team instead of opening up
the cell for a look." <http://www.eviloverlord.com/>