;; $Id: dbhtml.dsl,v 1.5 2004/10/10 11:55:10 petere78 Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
;;
;; ======================================================================
;; HTML Linking...
;;
(define (element-id #!optional (nd (current-node)))
;; IDs of TITLEs are the IDs of the PARENTs
(let ((elem (if (equal? (gi nd)
(normalize "title"))
(parent nd)
nd)))
(if (attribute-string (normalize "id") elem)
(attribute-string (normalize "id") elem)
(generate-anchor elem))))
(define (link-target idstring)
;; Return the HTML HREF for the given idstring. For RefEntrys, this is
;; just the name of the file, for anything else it's the name of the file
;; with the fragment identifier for the specified id.
(href-to (element-with-id idstring)))
(define (generate-anchor #!optional (nd (current-node)))
(string-append "AEN" (number->string (all-element-number nd))))
(define (generate-xptr #!optional (nd (current-node)))
;; returns the location of the current node in a modified xptr
;; syntax. This used to be used to calculate unique anchor names
;; in the HTML document. all-element-number seems like a better
;; way to go...so this function is probably never called anymore.
(let loop ((suffix "")
(nd nd))
(let ((eid (id nd)))
(if eid
(string-append "I("
eid
")"
(if (= (string-length suffix) 0)
""
(string-append "C"
suffix)))
(let ((par (parent nd)))
(if (not (node-list-empty? par))
(loop (string-append "("
(number->string (child-number nd))
","
(gi nd)
")"
suffix)
par)
(string-append (if (= (string-length suffix) 0)
"R"
"R,C")
suffix)))))))
;; ======================================================================
;; HTML output
;;
(define (html-document title-sosofo body-sosofo)
(let* (;; Let's look these up once, so that we can avoid calculating
;; them over and over again.
(prev (prev-chunk-element))
(next (next-chunk-element))
(prevm (prev-major-component-chunk-element))
(nextm (next-major-component-chunk-element))
(navlist (list prev next prevm nextm))
;; Let's make it possible to control the output even in the
;; nochunks case. Note: in the nochunks case, (chunk?) will
;; return #t for only the root element.
(make-entity? (and (or (not nochunks) rootchunk)
(chunk?)))
(make-head? (or make-entity?
(and nochunks
(node-list=? (current-node)
(sgml-root-element)))))
(doc-sosofo
(if make-head?
(make element gi: "HTML"
(make element gi: "HEAD"
(make element gi: "TITLE" title-sosofo)
($standard-html-header$ prev next prevm nextm))
(make element gi: "BODY"
attributes: (append
(list (list "CLASS" (gi)))
%body-attr%)
(header-navigation (current-node) navlist)
body-sosofo
(footer-navigation (current-node) navlist)))
body-sosofo)))
(if make-entity?
(make entity
system-id: (html-entity-file (html-file))
(html-doctype)
doc-sosofo)
(if (node-list=? (current-node) (sgml-root-element))
(make sequence
(html-doctype)
doc-sosofo)
doc-sosofo))))
(define (html-doctype)
(cond
((and %html-pubid% %html-sysid%)
(make document-type
name: "HTML"
public-id: %html-pubid%
system-id: %html-sysid%))
(%html-pubid%
(make document-type
name: "HTML"
public-id: %html-pubid%))
(%html-sysid%
(make document-type
name: "HTML"
system-id: %html-sysid%))
(else
(empty-sosofo))))
(define ($standard-html-header$ #!optional
(prev (prev-chunk-element))
(next (next-chunk-element))
(prevm (prev-major-component-chunk-element))
(nextm (next-major-component-chunk-element)))
;; A hook function to add additional tags to the HEAD of your HTML files
(let* ((info (info-element))
(kws (select-elements (descendants info) (normalize "keyword")))
(home (nav-home (current-node)))
(up (parent (current-node))))
(make sequence
;; Add the META NAME=GENERATOR tag
(make empty-element gi: "META"
attributes: (list (list "NAME" "GENERATOR")
(list "CONTENT" (stylesheet-version))))
;; Add the LINK REV=MADE tag
(if %link-mailto-url%
(make empty-element gi: "LINK"
attributes: (list (list "REV" "MADE")
(list "HREF" %link-mailto-url%)))
(empty-sosofo))
;; Add the LINK REL=HOME tag
(if (nav-home? (current-node))
(make empty-element gi: "LINK"
attributes: (append '(("REL" "HOME"))
(if (equal? (element-title-string home)
"")
'()
(list
(list "TITLE"
(element-title-string home))))
(list (list "HREF" (href-to home)))))
(empty-sosofo))
;; Add the LINK REL=UP tag
(if (nav-up? (current-node))
(if (or (node-list-empty? up)
(node-list=? up (sgml-root-element)))
(empty-sosofo)
(make empty-element gi: "LINK"
attributes: (append '(("REL" "UP"))
(if (equal? (element-title-string up)
"")
'()
(list
(list "TITLE"
(element-title-string up))))
(list (list "HREF" (href-to up))))))
(empty-sosofo))
;; Add the LINK REL=PREVIOUS tag
(if (node-list-empty? prev)
(empty-sosofo)
(make empty-element gi: "LINK"
attributes: (append '(("REL" "PREVIOUS"))
(if (equal? (element-title-string prev) "")
'()
(list
(list "TITLE"
(element-title-string prev))))
(list (list "HREF" (href-to prev))))))
;; Add the LINK REL=NEXT tag
(if (node-list-empty? next)
(empty-sosofo)
(make empty-element gi: "LINK"
attributes: (append '(("REL" "NEXT"))
(if (equal? (element-title-string next) "")
'()
(list
(list "TITLE"
(element-title-string next))))
(list (list "HREF" (href-to next))))))
;; Add META NAME=KEYWORD tags
(let loop ((nl kws))
(if (node-list-empty? nl)
(empty-sosofo)
(make sequence
(make empty-element gi: "META"
attributes: (list (list "NAME" "KEYWORD")
(list "CONTENT" (data (node-list-first nl)))))
(loop (node-list-rest nl)))))
;; Add LINK REL=STYLESHEET tag
(if %stylesheet%
(make empty-element gi: "LINK"
attributes: (list (list "REL" "STYLESHEET")
(list "TYPE" %stylesheet-type%)
(list "HREF" %stylesheet%)))
(empty-sosofo))
($user-html-header$ home up prev next))))
(define ($user-html-header$ #!optional
(home (empty-node-list))
(up (empty-node-list))
(prev (empty-node-list))
(next (empty-node-list)))
;; Add additional header tags.
(let loop ((tl %html-header-tags%))
(if (null? tl)
(empty-sosofo)
(make sequence
(make empty-element gi: (car (car tl))
attributes: (cdr (car tl)))
(loop (cdr tl))))))
(define ($html-body-start$)
(empty-sosofo))
(define ($html-body-content-start$)
(empty-sosofo))
(define ($html-body-content-end$)
(empty-sosofo))
(define ($html-body-end$)
(empty-sosofo))
(define (dingbat usrname)
;; Print dingbats and other characters selected by name
(let ((name (case-fold-down usrname)))
(case name
;; For backward compatibility
(("copyright") "(C)")
(("trademark") "TM")
;; Straight out of Unicode
(("ldquo") "\"")
(("rdquo") "\"")
(("lsquo") "'")
(("rsquo") "'")
(("ldquor") "\"")
(("rdquor") "\"")
(("raquo") ">>")
(("laquo") "<<")
(("rsaquo") ">")
(("lsaquo") "<")
(("nbsp") " ")
(("en-dash") "-")
(("em-dash") "--")
(("en-space") " ")
(("em-space") " ")
(("bullet") "*")
(("copyright-sign") "(C)")
(("registered-sign") "(R)")
(else
(let ((err (debug (string-append "No dingbat defined for: " name))))
"*")))))
(define (dingbat-sosofo usrname)
;; Print dingbats and other characters selected by name
(let ((name (case-fold-down usrname)))
(case name
;; For backward compatibility
(("copyright") (make entity-ref name: "copy"))
(("trademark") (make entity-ref name: "trade"))
;; Straight out of Unicode
(("ldquo") (literal "\""))
(("rdquo") (literal "\""))
(("lsquo") "'")
(("rsquo") "'")
(("raquo") (literal "\""))
(("laquo") (literal "\""))
(("rsaquo") (literal "\""))
(("lsaquo") (literal "\""))
(("nbsp") (make entity-ref name: "nbsp"))
(("en-dash") (literal "-"))
(("em-dash") (literal "--"))
(("en-space") (make entity-ref name: "nbsp"))
(("em-space") (make sequence
(make entity-ref name: "nbsp")
(make entity-ref name: "nbsp")))
(("bullet") (literal "*"))
(("copyright-sign") (make entity-ref name: "copy"))
(("registered-sign") (literal "(R)"))
(else
(let ((err (debug (string-append "No dingbat defined for: " name))))
(literal "*"))))))
(define (para-check #!optional (place 'stop))
(let ((inpara (equal? (gi (parent (current-node))) (normalize "para"))))
(if (and %fix-para-wrappers% inpara)
(if (equal? place 'stop)
(make formatting-instruction data: "</P>")
(make formatting-instruction data: "<P>"))
(empty-sosofo))))
;; ======================================================================
;; HTML element functions
(define ($block-container$)
(make element gi: "DIV"
attributes: (list
(list "CLASS" (gi)))
(make element gi: "A"
attributes: (list (list "NAME" (element-id)))
(empty-sosofo))
(process-children)))
(define ($paragraph$ #!optional (para-wrapper "P"))
(let ((footnotes (select-elements (descendants (current-node))
(normalize "footnote")))
(tgroup (have-ancestor? (normalize "tgroup"))))
(make sequence
(make element gi: para-wrapper
attributes: (append
(if %default-quadding%
(list (list "ALIGN" %default-quadding%))
'()))
(process-children))
(if (or %footnotes-at-end% tgroup (node-list-empty? footnotes))
(empty-sosofo)
(make element gi: "BLOCKQUOTE"
attributes: (list
(list "CLASS" "FOOTNOTES"))
(with-mode footnote-mode
(process-node-list footnotes)))))))
(define ($indent-para-container$)
(make element gi: "BLOCKQUOTE"
attributes: (list
(list "CLASS" (gi)))
(process-children)))
(define ($bold-seq$ #!optional (sosofo (process-children)))
(make element gi: "B"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($italic-seq$ #!optional (sosofo (process-children)))
(make element gi: "I"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($bold-italic-seq$ #!optional (sosofo (process-children)))
(make element gi: "B"
attributes: (list
(list "CLASS" (gi)))
(make element gi: "I"
sosofo)))
(define ($mono-seq$ #!optional (sosofo (process-children)))
;; please avoid using this, TT is presentational
(make element gi: "TT"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($code-seq$ #!optional (sosofo (process-children)))
;; fragments of computer code
(make element gi: "CODE"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($samp-seq$ #!optional (sosofo (process-children)))
;; sample output from programs, scripts, etc
(make element gi: "SAMP"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($kbd-seq$ #!optional (sosofo (process-children)))
;; text to be entered by the user
(make element gi: "KBD"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($abbr-seq$ #!optional (sosofo (process-children)))
;; abbreviated form
;; FIXME: html4 only
(make element gi: "ABBR"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($acronym-seq$ #!optional (sosofo (process-children)))
;; FIXME: html4 only
(make element gi: "ACRONYM"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($var-seq$ #!optional (sosofo (process-children)))
;; variable or program argument
(make element gi: "VAR"
attributes: (list
(list "CLASS" (gi)))
sosofo))
(define ($italic-mono-seq$ #!optional (sosofo (process-children)))
(make element gi: "TT"
attributes: (list
(list "CLASS" (gi)))
(make element gi: "I"
sosofo)))
(define ($bold-mono-seq$ #!optional (sosofo (process-children)))
(make element gi: "TT"
attributes: (list
(list "CLASS" (gi)))
(make element gi: "B"
sosofo)))
(define ($charseq$ #!optional (sosofo (process-children)))
(make element gi: "SPAN"
attributes: (list
(list "CLASS" (gi)))
sosofo))
;; EOF dbhtml.dsl