*** empty log message ***

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2169 57a11ea4-9604-0410-9ed3-97b8803252fd

src/scm/html-generator.scm

@@ -1,32 +1,262 @@
 ;;;; $Id$
 ;;;; HTML Support functions 
 
+;; primarily Bryan Larsen (blarsen@ada-works.com) with help from
+;; pretty much everybody involved with reports.
+
 (gnc:support "html-generator.scm")
 
+
+;; How this mechanism works:
+;;
+;; To do a report, first collect all of your results into a list.
+;; Each item in the list corresponds to one entry.  One entry may
+;; correspond to more than one line in the report, though.
+;; 
+;; Assemble a list of report-spec-structure's.  Each entry in the
+;; report-spec-structure corresponds to one column in the HTML report.
+;; Perhaps the most important parameter in the structure is
+;; get-value-proc, which extracts the value to print in the column
+;; from the entry.
+;;
+;; If total-proc and total-html-proc are defined, the column is totalled.
+;;
+;; Subentries are handled several different ways, depending on what
+;; function is used to convert the results into an html table.  If
+;; subs-list-proc and subentry-html-proc are #f, there are no
+;; subentries in this column.  Instead, false-proc is called to
+;; assemble the list.  false-proc is a parameter that is passed to the
+;; function that converts the results into an HTML table.  false-proc,
+;; when passed an entry, returns a list of #f's the same length as the
+;; number of subentries.
+;;
+;; Subsections (which are not yet implemented) are defined in the
+;; report-sort-spec-structure.  Define subtotal-html-proc to allow
+;; this column to be totalled.
+;;
+;; Note that pretty much every parameter may be set to #f.  For
+;; example, to define a "total column", you may wish to add an entry
+;; 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
+;;  get-value-proc:  given the entry, finds the value
+;;  html-proc: converts the value into html
+;;  total-proc:  usually + or #f
+;;  subtotal-html-proc: converts the subtotal into html
+;;  total-html-proc: converts the total into html
+;;  first-last-preference: #t if, for this column, entries should be
+;;                         displayed before subentries.  #f is
+;;                         subentries before entries.  This parameter
+;;                         may be ignored, depending on the report
+;;                         style chosen.
+;;  subs-list-proc: a procedure that returns a list of subentry values
+;;  subentry-html-proc: converts a subentry value into html
+(define report-spec-structure
+  (make-record-type
+   "report-spec-structure"
+   '(header get-value-proc html-proc total-proc
+	    subtotal-html-proc total-html-proc
+	    first-last-preference subs-list-proc subentry-html-proc)))
+
+;; The proposed sorting mechanism.  Of course, if you just wanted it
+;; sorted, you could sort the list before converting it into HTML.
+;; However, by doing it this way, we can divide things into
+;; subsections as well.
+;;
+;; To sort, collect a list of report-sort-spec-structure's.  The first
+;; item in the list is the primary sort, and so on down.
+;;
+;; Optionally, one can divide the report into subsections.  To do so,
+;; set the subsection-pred.  subsection-pred returns true if two
+;; values are in the same subsection.  All values in the subsection
+;; must be adjacent for the sort-pred.  For example, one could sort by
+;; date, and then supply a subsection-pred that determines whether two
+;; dates are within the same month.
+;;
+;; report-sort-spec-structure
+;;  get-value-proc:  given the entry, finds the value.  Required.
+;;  sort-pred:  usually <.  Required.
+;;  subsection-pred: often = or #f.  Returns #t if both values are in
+;;                   the same subsection
+;;  subsection-title-proc: returns the title of the subsection given a
+;;                         value.  #f indicates no title.
+(define report-sort-spec-structure
+  (make-record-type
+   "report-sort-spec-structure"
+   '(get-value-proc sort-pred subsection-pred subsection-title-proc)))
+
+(define make-report-sort-spec
+  (record-constructor report-sort-spec-structure))
+
+(define report-sort-spec-get-get-value-proc
+  (record-accessor report-sort-spec-structure 'get-value-proc))
+
+(define report-sort-spec-get-sort-pred
+  (record-accessor report-sort-spec-structure 'sort-pred))
+
+(define report-sort-spec-get-subsection-pred
+  (record-accessor report-sort-spec-structure 'subsection-pred))
+
+(define report-sort-spec-get-subsection-title-proc
+  (record-accessor report-sort-spec-structure 'subsection-title-proc))
+
+(define make-report-spec
+  (record-constructor report-spec-structure))
+
+(define report-spec-get-header
+  (record-accessor report-spec-structure 'header))
+
+(define report-spec-get-get-value-proc
+  (record-accessor report-spec-structure 'get-value-proc))
+
+(define report-spec-get-html-proc
+  (record-accessor report-spec-structure 'html-proc))
+
+(define report-spec-get-total-proc
+  (record-accessor report-spec-structure 'total-proc))
+
+(define report-spec-get-subtotal-html-proc
+  (record-accessor report-spec-structure 'subtotal-html-proc))
+
+(define report-spec-get-total-html-proc
+  (record-accessor report-spec-structure 'total-html-proc))
+
+(define report-spec-get-subs-list-proc
+  (record-accessor report-spec-structure 'subs-list-proc))
+
+(define report-spec-get-subentry-html-proc
+  (record-accessor report-spec-structure 'subentry-html-proc))
+
+(define report-spec-get-first-last-preference
+  (record-accessor report-spec-structure 'first-last-preference))
+
+;; convert table to html.  Subentries follow entries
+(define (html-table-entries-first lst specs false-proc)
+  (map  ;; map-in-order when it's fixed
+   (lambda (line)
+     (html-table-row-group
+      (list
+       (html-table-row-manual (html-table-do-entry line specs))
+       (map
+	html-table-row-manual
+	(html-table-collect-subentries line specs false-proc)))))
+   lst))
+
+;; convert table to html.  The first subentry is merged with the
+;; entries on the first line.     
+(define (html-table-subentries-merged lst specs false-proc)
+  (map ;; map-in-order
+   (lambda (line)
+     (let ((subs-lines (html-table-collect-subentries line specs false-proc)))
+       (html-table-row-group
+	(list
+	(html-table-row-manual
+	 (map
+	  (lambda (entry sub)
+	    (if (not sub) entry sub))
+	  (html-table-do-entry line specs)
+	  (car subs-lines)))
+	(map html-table-row-manual (cdr subs-lines))))))
+   lst))
+
+;; convert table to html.  Entries only
+(define (html-table-entries-only lst specs false-proc)
+  (map ;; map-in-order
+   (lambda (line)
+     (html-table-row-manual (html-table-do-entry line specs)))
+   lst))
+
+;; convert totals to html
+(define (html-table-totals lst specs)
+  (html-table-row-manual
+   (map
+    (lambda (spec)
+      (cond ((report-spec-get-total-html-proc spec)
+	     ((report-spec-get-total-html-proc spec)
+	      (apply
+	       (report-spec-get-total-proc spec)
+	       (map (report-spec-get-get-value-proc spec) lst))))
+	    (else #f)))
+    specs)))
+
+;; convert headers to html
+(define (html-table-headers specs)
+  (map
+   (lambda (spec) 
+     (html-header-cell 
+      (report-spec-get-header spec)))
+   specs))
+
+;; converts from col order to row order.
+;; ex.  ((a b) (c d) (e f)) -> ((a c e) (b d f))
+(define (col-list->row-list lst)
+  (apply map list lst))
+
+;;;;;;;;;;;;;;;;
+;; the rest are just helper functions
+
+;; converts subentries into html and collects into a list of lists of
+;; html cells.
+(define (html-table-collect-subentries line specs false-proc)
+  (col-list->row-list
+   (map
+    (lambda (spec)
+      (cond ((report-spec-get-subs-list-proc spec) 
+	     (map
+	      (report-spec-get-subentry-html-proc spec)
+	      ((report-spec-get-subs-list-proc spec) line)))
+	    (else (false-proc line))))
+    specs)))
+
+;; converts entry into a list of html cells.
+(define (html-table-do-entry line specs)
+  (map
+   (lambda (spec)
+     (cond ((report-spec-get-get-value-proc spec)
+	    ((report-spec-get-html-proc spec)
+	     ((report-spec-get-get-value-proc spec) line)))
+	   (else #f)))
+   specs))
+
 (define (html-table-row-manual items)
   (list
-   '("<TR>")
+   "<TR>"
-   items
-   '("</TR>")))
-
-(define (html-table-row-guess header? strong? items)
-  (html-table-row-manual
    (map
-    (lambda (item)
+    (lambda (cell)
-      (html-cell header? strong? item))
+      (cond (cell cell)
-    items)))
+	    (else html-blank-cell)))
+    items)
+   "</TR>"))
 
-(define (html-strong cell)
+;; help! this doesn't work!  I want something to group several rows
-  (string-append
+;; together so that an "entry" is noticably one unit.
-   "<STRONG>"
+(define (html-table-row-group rows)
-   cell
+  (list  "<TBODY>" rows  "</TBODY>"))
-   "</STRONG>"))
 
-(define (html-currency-cell header? strong? amount)
+(define (html-strong html)
-  (html-generic-cell
+  (if html 
-   #t
+      (string-append "<STRONG>" html "</STRONG>")
-   header?
+      #f))
-   strong?
+
+(define (html-make-strong proc)
+  (lambda (val)
+    (html-strong (proc val))))
+
+(define (html-ital html)
+  (if html
+      (string-append  "<i>"  html "</i>")
+      #f))
+
+(define (html-make-ital proc)
+  (lambda (val)
+    (html-ital (proc val))))
+
+(define (html-currency amount)
+  (if amount
       (string-append
        "<font face=\"Courier\""
        (if (< amount 0)
@@ -38,56 +268,42 @@
 	    ">&nbsp;"
 	    (gnc:amount->string amount #f #t #f)
 	    "&nbsp;"))
-    "</font>")))
+       "</font>")
+      #f))
 
-(define (html-generic-cell right-align? header? strong? item)
+(define (html-left-cell item)
-  (string-append
+  (if item
-   (if header? "<TH justify=center" "<TD")
+      (string-append "<TD>" item "</TD>")
-   (if right-align? " align=right>" ">")
+      #f))
-   (if strong? "<strong>" "")
-   item
-   (if strong? "</strong>" "")
-   (if header? "</TH>" "</TD>")))
 
-(define (html-number-cell header? strong? format number)
+(define (html-make-left-cell proc)
-  (html-generic-cell
+  (lambda (val)
-   #t
+    (html-left-cell (proc val))))
-   header?
-   strong?
-   (sprintf #f format number)))
 
-(define (html-add-cell header? strong? cline item)
+(define (html-right-cell item)
-  (string-append cline (html-cell header? strong? item)))
+  (if item
+      (string-append "<TD align=right>" item "</TD>")
+      #f))
 
-;; guess at what type they want
+(define html-blank-cell
-(define (html-cell header? strong? item)
+  "<TD></TD>")
-  (cond ((string? item) 
-	 (html-generic-cell #f header? strong? item))
-	((number? item)
-	 (html-currency-cell header? strong? item))
-	(else "")))
 
-(define (html-cell-header item)
+(define (html-make-right-cell proc)
-  (html-cell #t #f item))
+  (lambda (val)
+    (html-right-cell (proc val))))
 
-(define (html-cell-body item)
+(define (html-header-cell item)
-  (html-cell #f #f item))
+  (string-append "<TH justify=left>" item "</TH>"))
 
-(define (html-cell-header-strong item)
+(define (html-string string)
-  (html-cell #t #t item))
+  (if string string #f))
 
-(define (html-cell-body-strong item)
+(define (html-number format number)
-  (html-cell #f #t item))
+  (if number (sprintf #f format number) #f))
-
-(define (html-cell-header-right item)
-  (html-generic-cell #t #t #f item))
 
 (define (html-para text)
   (string-append "<P>" text "</P>\n"))
 
-(define (html-cell-attributes value attributes)
-  (string-append "<TD " attributes ">" value "</TD>"))
-
 (define (html-start-document-title title)
   (list 
    "<HTML>"
@@ -112,7 +328,7 @@
    "</HTML>"))
 
 (define (html-start-table)
-  (list "<TABLE border=1>"))
+  (list "<TABLE border=2 rules=\"groups\">"))
 
 (define (html-end-table)
   (list "</table>"))
@@ -120,6 +336,7 @@
 
 ;;;;;;;;;;;;;;;;;;;;
 ;; HTML Table
+;; This is used by balance-and-pnl.
 ;;;;;;;;;;;;;;;;;;;;
 
 ; Convert to string