;;; html.scm -- HTML engine.
;;;
;;; Copyright 2003, 2004 Manuel Serrano
;;; Copyright 2005, 2006 Ludovic Courtès
;;;
;;;
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo engine html)
:autoload (skribilo parameters) (*destination-file*)
:use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)))
;; Keep a reference to the base engine.
(define base-engine (find-engine 'base))
(if (not (engine? base-engine))
(error "bootstrap problem: base engine broken" base-engine))
;*---------------------------------------------------------------------*/
;* html-file-default ... */
;*---------------------------------------------------------------------*/
(define html-file-default
;; Default implementation of the `file-name-proc' custom.
(let ((table '())
(filename (tmpnam)))
(define (get-file-name base suf)
(let* ((c (assoc base table))
(n (if (pair? c)
(let ((n (+ 1 (cdr c))))
(set-cdr! c n)
n)
(begin
(set! table (cons (cons base 1) table))
1))))
(format #f "~a-~a.~a" base n suf)))
(lambda (node e)
(let ((f (markup-option node filename))
(file (markup-option node :file)))
(cond
((string? f)
f)
((string? file)
file)
((or file
(and (is-markup? node 'chapter)
(engine-custom e 'chapter-file))
(and (is-markup? node 'section)
(engine-custom e 'section-file))
(and (is-markup? node 'subsection)
(engine-custom e 'subsection-file))
(and (is-markup? node 'subsubsection)
(engine-custom e 'subsubsection-file)))
(let* ((b (or (and (string? (*destination-file*))
(prefix (*destination-file*)))
""))
(s (or (and (string? (*destination-file*))
(suffix (*destination-file*)))
"html"))
(nm (get-file-name b s)))
(markup-option-add! node filename nm)
nm))
((document? node)
(*destination-file*))
(else
(let ((p (ast-parent node)))
(if (container? p)
(let ((file (html-file p e)))
(if (string? file)
(begin
(markup-option-add! node filename file)
file)
#f))
#f))))))))
;*---------------------------------------------------------------------*/
;* html-engine ... */
;*---------------------------------------------------------------------*/
(define-public html-engine
;; setup the html engine
(default-engine-set!
(make-engine 'html
:version 1.0
:format "html"
:delegate (find-engine 'base)
:filter (make-string-replace '((#\< "<")
(#\> ">")
(#\& "&")
(#\" """)
(#\@ "@")))
:custom `(;; the icon associated with the URL
(favicon #f)
;; charset used
(charset "ISO-8859-1")
;; enable/disable Javascript
(javascript #f)
;; user html head
(head #f)
;; user CSS
(css ())
;; user inlined CSS
(inline-css ())
;; user JS
(js ())
;; emit-sui
(emit-sui #f)
;; the body
(background #f)
(foreground #f)
;; the margins
(margin-padding 3)
(left-margin #f)
(chapter-left-margin #f)
(section-left-margin #f)
(left-margin-font #f)
(left-margin-size 17.)
(left-margin-background #f)
(left-margin-foreground #f)
(right-margin #f)
(chapter-right-margin #f)
(section-right-margin #f)
(right-margin-font #f)
(right-margin-size 17.)
(right-margin-background #f)
(right-margin-foreground #f)
;; author configuration
(author-font #f)
;; title configuration
(title-font #f)
(title-background #f)
(title-foreground #f)
(file-title-separator " -- ")
;; html file naming
(file-name-proc ,html-file-default)
;; index configuration
(index-header-font-size #f) ;; +2.
;; chapter configuration
(chapter-number->string number->string)
(chapter-file #f)
;; section configuration
(section-title-start "
\n")
;; the children
(for-each (lambda (n) (toc-entry n (+ 1 level))) ch)))
(let* ((c (markup-option n :chapter))
(s (markup-option n :section))
(ss (markup-option n :subsection))
(sss (markup-option n :subsubsection))
(b (markup-body n))
(bb (if (handle? b)
(handle-ast b)
b)))
(if (not (container? bb))
(error 'toc
"Illegal body (container expected)"
(if (markup? bb)
(markup-markup bb)
"???"))
(let ((lst (find-down (lambda (x)
(and (markup? x)
(markup-option x :toc)
(or (and sss (is-markup? x 'subsubsection))
(and ss (is-markup? x 'subsection))
(and s (is-markup? x 'section))
(and c (is-markup? x 'chapter))
(markup-option n (symbol->keyword
(markup-markup x))))))
(container-body bb))))
;; avoid to produce an empty table
(unless (null? lst)
(display "
\n\n")
(for-each (lambda (n) (toc-entry n 0)) lst)
(display "\n
\n")))))))
;*---------------------------------------------------------------------*/
;* &html-generic-document ... */
;*---------------------------------------------------------------------*/
(define (&html-generic-document n title e)
(let* ((id (markup-ident n))
(header (new markup
(markup '&html-chapter-header)
(ident (string-append id "-header"))
(class (markup-class n))
(parent n)
(body (html-browser-title n))))
(meta (new markup
(markup '&html-meta)
(ident (string-append id "-meta"))
(class (markup-class n))
(parent n)
(body (markup-option (ast-document n) :keywords))))
(head (new markup
(markup '&html-head)
(ident (string-append id "-head"))
(class (markup-class n))
(parent n)
(body (list header meta))))
(ftnote (new markup
(markup '&html-footnotes)
(ident (string-append id "-footnote"))
(class (markup-class n))
(parent n)
(body (reverse!
(container-env-get n 'footnote-env)))))
(page (new markup
(markup '&html-page)
(ident (string-append id "-page"))
(class (markup-class n))
(parent n)
(body (list (markup-body n) ftnote))))
(ending (new markup
(markup '&html-ending)
(ident (string-append id "-ending"))
(class (markup-class n))
(parent n)
(body (or (markup-option n :ending)
(let ((p (ast-document n)))
(and p (markup-option p :ending)))))))
(body (new markup
(markup '&html-body)
(ident (string-append id "-body"))
(class (markup-class n))
(parent n)
(body (list title page ending))))
(html (new markup
(markup '&html-html)
(ident (string-append id "-html"))
(class (markup-class n))
(parent n)
(body (list head body)))))
;; No file must be opened for documents. These files are
;; directly opened by Skribe
(if (document? n)
(output html e)
(with-output-to-file (html-file n e)
(lambda ()
(output html e))))))
;*---------------------------------------------------------------------*/
;* &html-generic-subdocument ... */
;*---------------------------------------------------------------------*/
(define (&html-generic-subdocument n e)
(let* ((p (ast-document n))
(id (markup-ident n))
(ti (let* ((nb (html-container-number n e))
(tc (markup-option n :title))
(ti (if (document? p)
(list (markup-option p :title)
(engine-custom e 'file-title-separator)
tc)
tc))
(sep (engine-custom
e
(symbol-append (markup-markup n)
'-title-number-separator)))
(nti (and tc
(if (and nb (not (equal? nb "")))
(list nb
(if (unspecified? sep) ". " sep)
ti)
ti))))
(new markup
(markup (symbol-append '&html- (markup-markup n) '-title))
(ident (string-append id "-title"))
(parent n)
(options '((author ())))
(body nti)))))
(case (markup-markup n)
((chapter)
(skribe-message " [~s chapter: ~a]\n" (engine-ident e) id))
((section)
(skribe-message " [~s section: ~a]\n" (engine-ident e) id)))
(&html-generic-document n ti e)))
;*---------------------------------------------------------------------*/
;* chapter ... @label chapter@ */
;*---------------------------------------------------------------------*/
(markup-writer 'chapter
:options '(:title :number :file :toc :html-title :env)
:before (lambda (n e)
(let ((title (markup-option n :title))
(ident (markup-ident n)))
(display "\n")
(display "\n")
(display "
")
(output (html-container-number n e) e)
(display " ")
(output (markup-option n :title) e)
(display "
")))
:after " ")
;; This writer is invoked only for chapters rendered inside separate files!
(markup-writer 'chapter
:options '(:title :number :file :toc :html-title :env)
:predicate (lambda (n e)
(or (markup-option n :file)
(engine-custom e 'chapter-file)))
:action &html-generic-subdocument)
;*---------------------------------------------------------------------*/
;* html-section-title ... */
;*---------------------------------------------------------------------*/
(define (html-section-title n e)
(let* ((title (markup-option n :title))
(number (markup-option n :number))
(c (markup-class n))
(ident (markup-ident n))
(kind (markup-markup n))
(tbg (engine-custom e (symbol-append kind '-title-background)))
(tfg (engine-custom e (symbol-append kind '-title-foreground)))
(tstart (engine-custom e (symbol-append kind '-title-start)))
(tstop (engine-custom e (symbol-append kind '-title-stop)))
(nsep (engine-custom e (symbol-append kind '-title-number-separator))))
;; the section header
(display "\n")
(display "\n")
(if c
(printf "