IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Whitespace cosmetics

Browse Source 
Replace tabs with spaces
Align some related lines
Remove trailing whitespace
This commit is contained in:
Geert Janssens 2014-12-18 16:47:20 +01:00 committed by Geert Janssens
parent 4f5658fc7a
commit 539ef52837
1 changed files with 103 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

206
src/report/report-system/html-document.scm
View File

@ -1,18 +1,18 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-document.scm : generate HTML programmatically, with support ;; html-document.scm : generate HTML programmatically, with support
;; for simple style elements. ;; for simple style elements.
;; Copyright 2000 Bill Gribble <grib@gnumatic.com> ;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;; ;;
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of ;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version. ;; the License, or (at your option) any later version.
;; ;;
;; This program is distributed in the hope that it will be useful, ;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details. ;; GNU General Public License for more details.
;; ;;
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact: ;; along with this program; if not, contact:
;; ;;
@ -25,29 +25,29 @@
(use-modules (gnucash printf)) (use-modules (gnucash printf))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-document> class ;; <html-document> class
;; this is the top-level object representing an entire HTML document. ;; this is the top-level object representing an entire HTML document.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <html-document> (define <html-document>
(make-record-type "<html-document>" (make-record-type "<html-document>"
'(style-sheet style-stack style style-text title headline objects))) '(style-sheet style-stack style style-text title headline objects)))
(define gnc:html-document? (define gnc:html-document?
(record-predicate <html-document>)) (record-predicate <html-document>))
(define gnc:make-html-document-internal (define gnc:make-html-document-internal
(record-constructor <html-document>)) (record-constructor <html-document>))
(define (gnc:make-html-document) (define (gnc:make-html-document)
(gnc:make-html-document-internal (gnc:make-html-document-internal
#f ;; the stylesheet #f ;; the stylesheet
'() ;; style stack '() ;; style stack
(gnc:make-html-style-table) ;; document style info (gnc:make-html-style-table) ;; document style info
#f ;; style text #f ;; style text
"" ;; document title "" ;; document title
#f ;; headline #f ;; headline
'() ;; subobjects '() ;; subobjects
)) ))
(define gnc:html-document-set-title! (define gnc:html-document-set-title!
@ -102,9 +102,9 @@
(let ((newstyle #f)) (let ((newstyle #f))
(if (and (= (length rest) 2) (if (and (= (length rest) 2)
(procedure? (car rest))) (procedure? (car rest)))
(set! newstyle (set! newstyle
(apply gnc:make-html-data-style-info rest)) (apply gnc:make-html-data-style-info rest))
(set! newstyle (set! newstyle
(apply gnc:make-html-markup-style-info rest))) (apply gnc:make-html-markup-style-info rest)))
(gnc:html-style-table-set! (gnc:html-document-style doc) tag newstyle))) (gnc:html-style-table-set! (gnc:html-document-style doc) tag newstyle)))
@ -117,7 +117,7 @@
(set! retval (cons elt retval)) (set! retval (cons elt retval))
(if (not (list? elt)) (if (not (list? elt))
(set! retval (set! retval
(cons (with-output-to-string (cons (with-output-to-string
(lambda () (display elt))) (lambda () (display elt)))
retval)) retval))
(do-list elt)))) (do-list elt))))
@ -127,66 +127,66 @@
;; first optional argument is "headers?" ;; first optional argument is "headers?"
;; returns the html document as a string, I think. ;; returns the html document as a string, I think.
(define (gnc:html-document-render doc . rest) (define (gnc:html-document-render doc . rest)
(let ((stylesheet (gnc:html-document-style-sheet doc)) (let ((stylesheet (gnc:html-document-style-sheet doc))
(headers? (if (null? rest) #f (if (car rest) #t #f))) (headers? (if (null? rest) #f (if (car rest) #t #f)))
(style-text (gnc:html-document-style-text doc)) (style-text (gnc:html-document-style-text doc))
) )
(if stylesheet (if stylesheet
;; if there's a style sheet, let it do the rendering ;; if there's a style sheet, let it do the rendering
(gnc:html-style-sheet-render stylesheet doc headers?) (gnc:html-style-sheet-render stylesheet doc headers?)
;; otherwise, do the trivial render. ;; otherwise, do the trivial render.
(let* ((retval '()) (let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))) (push (lambda (l) (set! retval (cons l retval))))
(objs (gnc:html-document-objects doc)) (objs (gnc:html-document-objects doc))
(work-to-do (length objs)) (work-to-do (length objs))
(css? (gnc-html-engine-supports-css)) (css? (gnc-html-engine-supports-css))
(work-done 0) (work-done 0)
(title (gnc:html-document-title doc))) (title (gnc:html-document-title doc)))
;; compile the doc style ;; compile the doc style
(gnc:html-style-table-compile (gnc:html-document-style doc) (gnc:html-style-table-compile (gnc:html-document-style doc)
(gnc:html-document-style-stack doc)) (gnc:html-document-style-stack doc))
;; push it ;; push it
(gnc:html-document-push-style doc (gnc:html-document-style doc)) (gnc:html-document-push-style doc (gnc:html-document-style doc))
(if (not (string-null? title)) (if (not (string-null? title))
(gnc:report-render-starting (gnc:html-document-title doc))) (gnc:report-render-starting (gnc:html-document-title doc)))
(if (not (null? headers?)) (if (not (null? headers?))
(begin (begin
;;This is the only place where <html> appears ;;This is the only place where <html> appears
;;with the exception of 2 reports: ;;with the exception of 2 reports:
;;./share/gnucash/scm/gnucash/report/taxinvoice.eguile.scm:<html> ;;./share/gnucash/scm/gnucash/report/taxinvoice.eguile.scm:<html>
;;./share/gnucash/scm/gnucash/report/balsheet-eg.eguile.scm:<html> ;;./share/gnucash/scm/gnucash/report/balsheet-eg.eguile.scm:<html>
(push "<head>\n") (push "<head>\n")
(push "<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n") (push "<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n")
(if css? (if css?
(if style-text (if style-text
(push (list "</style>" style-text "<style type=\"text/css\">\n")))) (push (list "</style>" style-text "<style type=\"text/css\">\n"))))
(let ((title (gnc:html-document-title doc))) (let ((title (gnc:html-document-title doc)))
(if title (if title
(push (list "</title>" title "<title>\n")))) (push (list "</title>" title "<title>\n"))))
(push "</head>\n") (push "</head>\n")
;; this lovely little number just makes sure that <body> ;; this lovely little number just makes sure that <body>
;; attributes like bgcolor get included ;; attributes like bgcolor get included
(push ((gnc:html-markup/open-tag-only "body") doc)))) (push ((gnc:html-markup/open-tag-only "body") doc))))
;; now render the children ;; now render the children
(for-each (for-each
(lambda (child) (lambda (child)
(begin (begin
(push (gnc:html-object-render child doc)) (push (gnc:html-object-render child doc))
(set! work-done (+ 1 work-done)) (set! work-done (+ 1 work-done))
(gnc:report-percent-done (* 100 (/ work-done work-to-do))))) (gnc:report-percent-done (* 100 (/ work-done work-to-do)))))
objs) objs)
(if (not (null? headers?)) (if (not (null? headers?))
(begin (begin
(push "</body>\n") (push "</body>\n")
(push "</html>\n"))) (push "</html>\n")))
(gnc:report-finished) (gnc:report-finished)
(gnc:html-document-pop-style doc) (gnc:html-document-pop-style doc)
(gnc:html-style-table-uncompile (gnc:html-document-style doc)) (gnc:html-style-table-uncompile (gnc:html-document-style doc))
@ -194,18 +194,18 @@
(define (gnc:html-document-push-style doc style) (define (gnc:html-document-push-style doc style)
(gnc:html-document-set-style-stack! (gnc:html-document-set-style-stack!
doc (cons style (gnc:html-document-style-stack doc)))) doc (cons style (gnc:html-document-style-stack doc))))
(define (gnc:html-document-pop-style doc) (define (gnc:html-document-pop-style doc)
(if (not (null? (gnc:html-document-style-stack doc))) (if (not (null? (gnc:html-document-style-stack doc)))
(gnc:html-document-set-style-stack! (gnc:html-document-set-style-stack!
doc (cdr (gnc:html-document-style-stack doc))))) doc (cdr (gnc:html-document-style-stack doc)))))
(define (gnc:html-document-add-object! doc obj) (define (gnc:html-document-add-object! doc obj)
(gnc:html-document-set-objects! (gnc:html-document-set-objects!
doc doc
(append (gnc:html-document-objects doc) (append (gnc:html-document-objects doc)
(list (gnc:make-html-object obj))))) (list (gnc:make-html-object obj)))))
(define (gnc:html-document-append-objects! doc objects) (define (gnc:html-document-append-objects! doc objects)
@ -215,38 +215,38 @@
(define (gnc:html-document-fetch-markup-style doc markup) (define (gnc:html-document-fetch-markup-style doc markup)
(let ((style-info #f) (let ((style-info #f)
(style-stack (gnc:html-document-style-stack doc))) (style-stack (gnc:html-document-style-stack doc)))
(if (not (null? style-stack)) (if (not (null? style-stack))
(set! style-info (set! style-info
(gnc:html-style-table-fetch (gnc:html-style-table-fetch
(car style-stack) (car style-stack)
(cdr style-stack) (cdr style-stack)
markup))) markup)))
(if (not style-info) (if (not style-info)
(gnc:make-html-markup-style-info) (gnc:make-html-markup-style-info)
style-info))) style-info)))
(define (gnc:html-document-fetch-data-style doc markup) (define (gnc:html-document-fetch-data-style doc markup)
(let ((style-info #f) (let ((style-info #f)
(style-stack (gnc:html-document-style-stack doc))) (style-stack (gnc:html-document-style-stack doc)))
(if (not (null? (gnc:html-document-style-stack doc))) (if (not (null? (gnc:html-document-style-stack doc)))
(set! style-info (set! style-info
(gnc:html-style-table-fetch (gnc:html-style-table-fetch
(car style-stack) (car style-stack)
(cdr style-stack) (cdr style-stack)
markup))) markup)))
(if (not style-info) (if (not style-info)
(gnc:make-html-data-style-info (gnc:make-html-data-style-info
(lambda (datum parms) (lambda (datum parms)
(sprintf #f "%a %a" markup datum)) (sprintf #f "%a %a" markup datum))
#f) #f)
style-info))) style-info)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; markup-rendering functions : markup-start and markup-end return ;; markup-rendering functions : markup-start and markup-end return
;; pre-body and post-body HTML for the given markup tag. ;; pre-body and post-body HTML for the given markup tag.
;; the optional rest arguments are lists of attribute-value pairs: ;; the optional rest arguments are lists of attribute-value pairs:
;; (gnc:html-document-markup-start doc "markup" ;; (gnc:html-document-markup-start doc "markup"
;; '("attr1" "value1") '("attr2" "value2")) ;; '("attr1" "value1") '("attr2" "value2"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -273,11 +273,11 @@
(add-internal-tag (lambda (tag) (push "<") (push tag) (push ">"))) (add-internal-tag (lambda (tag) (push "<") (push tag) (push ">")))
(add-attribute (add-attribute
(lambda (key value prior) (lambda (key value prior)
(push " ") (push key) (push " ") (push key)
(if value (begin (push "=\"") (if value (begin (push "=\"")
(push value) (push value)
(push "\""))) (push "\"")))
#t)) #t))
(addextraatt (addextraatt
(lambda (attr) (lambda (attr)
(cond ((string? attr) (push " ") (push attr)) (cond ((string? attr) (push " ") (push attr))
@ -343,14 +343,14 @@
retval)))) retval))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-document-render-data ;; html-document-render-data
;; looks up the relevant data style and renders the data accordingly ;; looks up the relevant data style and renders the data accordingly
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:html-document-render-data doc data) (define (gnc:html-document-render-data doc data)
(let ((style-info #f) (let ((style-info #f)
(data-type #f)) (data-type #f))
(cond (cond
((number? data) ((number? data)
(set! data-type "<number>")) (set! data-type "<number>"))
((string? data) ((string? data)
@ -359,11 +359,11 @@
(set! data-type "<boolean>")) (set! data-type "<boolean>"))
((record? data) ((record? data)
(set! data-type (record-type-name (record-type-descriptor data)))) (set! data-type (record-type-name (record-type-descriptor data))))
(#t (#t
(set! data-type "<generic>"))) (set! data-type "<generic>")))
(set! style-info (gnc:html-document-fetch-data-style doc data-type)) (set! style-info (gnc:html-document-fetch-data-style doc data-type))
((gnc:html-data-style-info-renderer style-info) ((gnc:html-data-style-info-renderer style-info)
data (gnc:html-data-style-info-data style-info)))) data (gnc:html-data-style-info-data style-info))))
@ -378,7 +378,7 @@
(define <html-object> (define <html-object>
(make-record-type "<html-object>" (make-record-type "<html-object>"
'(renderer data))) '(renderer data)))
(define gnc:html-object? (define gnc:html-object?
(record-predicate <html-object>)) (record-predicate <html-object>))
(define gnc:make-html-object-internal (define gnc:make-html-object-internal
@ -389,40 +389,40 @@
(if (not (record? obj)) (if (not (record? obj))
;; for literals (strings/numbers) ;; for literals (strings/numbers)
(set! o (set! o
(gnc:make-html-object-internal (gnc:make-html-object-internal
(lambda (obj doc) (lambda (obj doc)
(gnc:html-document-render-data doc obj)) (gnc:html-document-render-data doc obj))
;; if the object is #f, make it a placeholder ;; if the object is #f, make it a placeholder
(if obj obj "&nbsp;&nbsp;&nbsp;"))) (if obj obj "&nbsp;&nbsp;&nbsp;")))
(cond (cond
((gnc:html-text? obj) ((gnc:html-text? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-text-render obj))) gnc:html-text-render obj)))
((gnc:html-table? obj) ((gnc:html-table? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-table-render obj))) gnc:html-table-render obj)))
((gnc:html-table-cell? obj) ((gnc:html-table-cell? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-table-cell-render obj))) gnc:html-table-cell-render obj)))
((gnc:html-barchart? obj) ((gnc:html-barchart? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-barchart-render obj))) gnc:html-barchart-render obj)))
((gnc:html-piechart? obj) ((gnc:html-piechart? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-piechart-render obj))) gnc:html-piechart-render obj)))
((gnc:html-scatter? obj) ((gnc:html-scatter? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-scatter-render obj))) gnc:html-scatter-render obj)))
((gnc:html-linechart? obj) ((gnc:html-linechart? obj)
(set! o (gnc:make-html-object-internal (set! o (gnc:make-html-object-internal
gnc:html-linechart-render obj))) gnc:html-linechart-render obj)))
((gnc:html-object? obj) ((gnc:html-object? obj)
(set! o obj)) (set! o obj))
;; other record types that aren't HTML objects ;; other record types that aren't HTML objects
(#t (#t
(set! o (set! o
(gnc:make-html-object-internal (gnc:make-html-object-internal
(lambda (obj doc) (lambda (obj doc)
(gnc:html-document-render-data doc obj)) (gnc:html-document-render-data doc obj))
obj))))) obj)))))
@ -441,7 +441,7 @@
(record-modifier <html-object> 'data)) (record-modifier <html-object> 'data))
(define (gnc:html-object-render obj doc) (define (gnc:html-object-render obj doc)
(if (gnc:html-object? obj) (if (gnc:html-object? obj)
((gnc:html-object-renderer obj) (gnc:html-object-data obj) doc) ((gnc:html-object-renderer obj) (gnc:html-object-data obj) doc)
(let ((htmlo (gnc:make-html-object obj))) (let ((htmlo (gnc:make-html-object obj)))
(gnc:html-object-render htmlo doc)))) (gnc:html-object-render htmlo doc))))