diff --git a/src/scm/html-generator.scm b/src/scm/html-generator.scm index 97ebc67e8f..1f9fddb422 100644 --- a/src/scm/html-generator.scm +++ b/src/scm/html-generator.scm @@ -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 " ") ;;; Non-breaking space +;;; +;;; 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 "" html "") #f)) +(define (html-strong html) + (if html + (list "" html "") + #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 "" html "") #f)) +(define (html-ital html) + (if html + (list "" html "") + #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 "") #f)) +(define (html-font-and-color face color contents) + (list + "" + contents + "")) + +(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 "" item "") + (html-table-col-align item #f) #f)) (define (html-make-left-cell proc) @@ -436,28 +479,34 @@ (define (html-right-cell item) (if item - (string-append "" item "") + (html-table-col-align item "right") #f)) (define html-blank-cell - "") + (list "" NBSP "")) (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 "" item "")) +(define (html-header-cell item) + (html-table-headcol-justified item "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 "

" text "

\n")) +(define (html-para text) + (list "

" text "

\n")) + (define (html-start-document-title title color) (list "" @@ -465,11 +514,11 @@ "" title "" "" (if color - (string-append "") + (list "") ""))) (define (html-start-document-color color) - (list + (list "" "")) @@ -505,13 +554,21 @@ ; Create a column entry (define (html-table-col val) - (string-append "" (tostring val) "")) + (html-table-col-align "right" val)) -(define (html-table-col-align val align) +(define (string-html-table-col-align val align) (string-append "" (tostring val) "")) +(define (html-table-col-align val align) + (list "" + (tostring val) "")) + ; 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 +576,15 @@ (apply string-append (map html-table-col lst)) "")))) +(define (html-table-row lst) + (if (string? lst) + lst + (list "" + (map html-table-col lst) + ""))) + ; 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,18 +592,43 @@ (apply string-append (map html-table-col-align lst align-list)) "")))) +(define (html-table-row-align lst align-list) + (if (string? lst) + lst + (list "" + (map html-table-col-align lst align-list) + ""))) + ; 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 "" (tostring val) "")) -(define (html-table-header caption vec) +(define (html-table-headcol-justified val justification) + (list "" + (tostring val) + ")) + +(define (html-table-headcol val) + (html-table-headcol-justified val "center")) + +(define (string-html-table-header caption vec) (apply string-append "\n" (if caption @@ -547,5 +636,13 @@ "") (map html-table-headcol vec))) +(define (html-table-header caption vec) + (list + "
\n" + (if caption + (list "") + "") + (map html-table-headcol vec))) + (define (html-table-footer) "
" caption "
") diff --git a/src/scm/report.scm b/src/scm/report.scm index 88ea7dcddd..1a1b6faac4 100644 --- a/src/scm/report.scm +++ b/src/scm/report.scm @@ -45,23 +45,55 @@ item)) (else (gnc:warn "gnc:run-report - " item " is the wrong type.")))) - (define (report-output->string lines) - (call-with-output-string - (lambda (port) - (for-each - (lambda (item) (display-report-list-item item port)) - lines)))) - - (let ((report (hash-ref *gnc:_report-info_* report-name))) - (if report - (let* ((renderer (gnc:report-renderer report)) - (lines (renderer options)) - (output (report-output->string lines))) - output) - #f))) +;; 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) + (output-tree-to-port (car tree) port) + (output-tree-to-port (cdr tree) port)) + ((string? tree) + (display-report-list-item tree port) + (newline port)) + ((null? tree) + #f) ;;; Do Nothing... + (tree ;;; If it's not #f + (display-report-list-item " Error - Bad atom! " port) + (display-report-list-item tree port) + (display "Err: (") + (write tree) + (display ")") + (newline) + (newline port)))) + + (define (report-output->string tree) + (display "(Report-Tree ") + (display tree) + (display ")") + (newline) + (call-with-output-string + (lambda (port) + (output-tree-to-port tree port)))) + + (let ((report (hash-ref *gnc:_report-info_* report-name))) + (if report + (let* ((renderer (gnc:report-renderer report)) + (lines (renderer options)) + (output (report-output->string lines))) + output) + #f))) (define (gnc:report-menu-setup win) - (define menu (gnc:make-menu "_Reports" (list "_Accounts"))) (define menu-namer (gnc:new-menu-namer)) diff --git a/src/scm/report/balance-and-pnl.scm b/src/scm/report/balance-and-pnl.scm index b04eacff53..62cee70e7f 100644 --- a/src/scm/report/balance-and-pnl.scm +++ b/src/scm/report/balance-and-pnl.scm @@ -1,8 +1,24 @@ -;; -*-scheme-*- -;; $Id$ +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, contact: +;; +;; Free Software Foundation Voice: +1-617-542-5942 +;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 +;; Boston, MA 02111-1307, USA gnu@gnu.org + ;; Balance and Profit/Loss Reports (gnc:support "report/balance-and-pnl.scm") +(gnc:depend "html-generator.scm") (gnc:depend "text-export.scm") (gnc:depend "report-utilities.scm") (gnc:depend "options.scm") @@ -13,7 +29,7 @@ ((l0-collector (make-stats-collector)) (l1-collector (make-stats-collector)) (l2-collector (make-stats-collector))) - + (define string-db (gnc:make-string-database)) (define (balsht-options-generator) @@ -70,9 +86,9 @@ gnc:*pnl-report-options*) (define (render-level-2-account level-2-account l2-value) - (let ((account-name (string-append "    " - (gnc:account-get-full-name - level-2-account))) + (let ((account-name (list NBSP NBSP NBSP NBSP + (gnc:account-get-full-name + level-2-account))) (type-name (gnc:account-get-type-string (gnc:account-get-type level-2-account)))) (html-table-row-align @@ -84,17 +100,18 @@ (let ((name (gnc:account-get-full-name account)) (type (gnc:account-get-type-string (gnc:account-get-type account)))) (html-table-row-align - (list name type " " + (list name type NBSP (gnc:amount->formatted-string l1-value #f) - " " " ") + NBSP NBSP) (list "left" "center" "right" "right" "right" "right")))) (define (render-total l0-value) (html-table-row-align - (list " " " " " " - (html-strong (string-db 'lookup 'net)) - " " - (gnc:amount->formatted-string l0-value #f)) + (list (html-strong (string-db 'lookup 'net)) + NBSP NBSP + (gnc:amount->formatted-string l0-value #f) + NBSP NBSP + ) (list "left" "center" "right" "right" "right" "right"))) (define blank-line