]> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; CSTR modifications to modular docbook stylesheets. me of this could ;; ;; perhaps be split into parameters and more parametarisable ;; ;; definitions replaceing ones from the standard style sheets. ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define html-index #t ) (define %shade-verbatim% #t) (define %missing-link-error% #f) (define image-directory "images_gen") (define $generate-chapter-toc$ (lambda () #t)) (define %generate-book-toc% #f) (define ($shade-verbatim-attr$) ;; Attributes used to create a shaded verbatim environment. (list (list "BORDER" "0") (list "WIDTH" "80%"))) (define ($shade-verbatim-cell-attr$) ;; Attributes used to create a shaded verbatim environment. (list )) (define ($shade-verbatim-text-attr$) ;; Attributes used to create a shaded verbatim environment. (list (list "style" "white-space:pre; display:block;") (list "face" "monospace") (list "color" "#000000") )) (define %body-attr% ;; What attributes should be hung off of BODY? (list (list "BGCOLOR" "#FFFFFF") (list "BACKGROUND" "../cstr_background.jpg") (list "TEXT" "#0000AA") ) ) (define $line-annotation-attr$ ;; font attributes for line annotation (list (list "color" "#A00080") (list "size" "-1") (list "face" "sans") (list "weight" "bold") ) ) (element lineannotation (make element gi: "font" attributes: $line-annotation-attr$ (process-children)) ) (element screen (make element gi: "DIV" attributes: '(("ALIGN" "CENTER")) ($verbatim-display$ %number-screen-lines%) ) ) (element programlisting (make element gi: "DIV" attributes: '(("ALIGN" "CENTER")) ($verbatim-display$ %number-programlisting-lines%) ) ) (element sidebar (make element gi: "div" (make empty-element gi: "br" attributes: (list (list "clear" "right") ) ) (make element gi: "TABLE" attributes: (list (list "CLASS" (gi)) (list "BORDER" "1") (list "CELLPADDING" "5")) (make element gi: "TR" (make element gi: "TD" ($semiformal-object$)))) ) ) (define (default-header-nav-tbl-ff elemnode prev next prevsib nextsib) (let* ((r1? (nav-banner? elemnode)) (r1-sosofo (make element gi: "TR" (make element gi: "TH" attributes: (list (list "COLSPAN" "5") (list "ALIGN" "center") (list "VALIGN" "bottom")) (nav-banner elemnode)))) (r2? (or (not (node-list-empty? prev)) (not (node-list-empty? next)) (not (node-list-empty? prevsib)) (not (node-list-empty? nextsib)) (nav-context? elemnode))) (r2-sosofo (make element gi: "TR" (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "left") (list "VALIGN" "top")) (if (node-list-empty? prev) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to prev))) (gentext-nav-prev prev)))) (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "left") (list "VALIGN" "top")) (if (node-list-empty? prevsib) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to prevsib))) (gentext-nav-prevsib prevsib)))) (make element gi: "TD" attributes: (list (list "WIDTH" "60%") (list "ALIGN" "center") (list "VALIGN" "bottom")) (nav-context elemnode)) (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "right") (list "VALIGN" "top")) (if (node-list-empty? nextsib) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to nextsib))) (gentext-nav-nextsib nextsib)))) (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "right") (list "VALIGN" "top")) (if (node-list-empty? next) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to next))) (gentext-nav-next next))))))) (if (or r1? r2?) (make element gi: "DIV" attributes: '(("CLASS" "NAVHEADER")) (make element gi: "TABLE" attributes: (list (list "WIDTH" %gentext-nav-tblwidth%) (list "BORDER" "0") (list "CELLPADDING" "0") (list "CELLSPACING" "0")) (if r1? r1-sosofo (empty-sosofo)) (if r2? r2-sosofo (empty-sosofo))) (make empty-element gi: "HR" attributes: (list (list "ALIGN" "LEFT") (list "WIDTH" %gentext-nav-tblwidth%))) (make empty-element gi: "HR" attributes: (list (list "ALIGN" "LEFT") (list "WIDTH" %gentext-nav-tblwidth%)))) (empty-sosofo)))) (define (default-header-nav-tbl-noff elemnode prev next prevsib nextsib) (let* ((r1? (nav-banner? elemnode)) (limg (entity-text "title-left-image")) (rimg (entity-text "title-right-image")) (r1-sosofo (make element gi: "TR" (if limg (make element gi: "TH" attributes: (list (list "ROWSPAN" "2") (list "ALIGN" "left")) (make empty-element gi: "IMG" attributes: (list (list "SRC" limg) ) )) (empty-sosofo) ) (make element gi: "TH" attributes: (list (list "COLSPAN" "3") (list "ALIGN" "center")) (nav-banner elemnode)) (if rimg (make element gi: "TH" attributes: (list (list "ROWSPAN" "2") (list "ALIGN" "right")) (make empty-element gi: "IMG" attributes: (list (list "SRC" rimg) ) )) (empty-sosofo) ) )) (r2? (or (not (node-list-empty? prev)) (not (node-list-empty? next)) (nav-context? elemnode))) (r2-sosofo (make element gi: "TR" (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "left") (list "VALIGN" "bottom")) (if (node-list-empty? prev) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to prev))) (gentext-nav-prev prev)))) (make element gi: "TD" attributes: (list (list "WIDTH" "80%") (list "ALIGN" "center") (list "VALIGN" "bottom")) (nav-context elemnode)) (make element gi: "TD" attributes: (list (list "WIDTH" "10%") (list "ALIGN" "right") (list "VALIGN" "bottom")) (if (node-list-empty? next) (make entity-ref name: "nbsp") (make element gi: "A" attributes: (list (list "HREF" (href-to next))) (gentext-nav-next next))))))) (if (or r1? r2?) (make element gi: "DIV" attributes: '(("CLASS" "NAVHEADER")) (make element gi: "TABLE" attributes: (list (list "WIDTH" %gentext-nav-tblwidth%) (list "BORDER" "0") (list "CELLPADDING" "0") (list "CELLSPACING" "0")) (if r1? r1-sosofo (empty-sosofo)) (if r2? r2-sosofo (empty-sosofo))) (make empty-element gi: "HR" attributes: (list (list "ALIGN" "LEFT") (list "WIDTH" %gentext-nav-tblwidth%)))) (empty-sosofo)))) (define ($verbatim-display$ line-numbers?) (let ((content (make element gi: "font" attributes: ($shade-verbatim-text-attr$) (if line-numbers? ($verbatim-content-with-linenumbers$) ($verbatim-content$))))) (if %shade-verbatim% (make element gi: "TABLE" attributes: ($shade-verbatim-attr$) (make element gi: "TR" (make element gi: "TD" attributes: ($shade-verbatim-cell-attr$) content ))) content))) (define ($sect-toc$) (let ((depth (attribute-string "depth"))) ;; Called by the TITLE element so that it can come after the TITLE (build-toc (ancestor-member (current-node) (section-element-list)) (if depth (string->number depth) (toc-depth (ancestor-member (current-node) (section-element-list))) ) #t)) ) (define ($chapter-toc$) (let ((depth (attribute-string "depth"))) ;; Called by the TITLE element so that it can come after the TITLE (build-toc (ancestor-member (current-node) (component-element-list)) (if depth (string->number depth) (toc-depth (ancestor-member (current-node) (component-element-list))) ) #t))) (element (SECT1 TOC) (make element gi: "DIV" (process-children) ($sect-toc$) ) ) (element (SECT2 TOC) (make element gi: "DIV" (process-children) ($sect-toc$) ) ) (element (SECT3 TOC) (make element gi: "DIV" (process-children) ($sect-toc$) ) ) (element (CHAPTER TOC) (make element gi: "DIV" (process-children) ($chapter-toc$) ) ) (element (BOOK TOC) (make element gi: "DIV" (process-children) ($chapter-toc$) ) ) ;; Variable list (element variablelist (make sequence (make element gi: "blockquote" (make element gi: "table" attributes: '(("class" "parameters")) (process-children))) (para-check 'restart))) (element (variablelist title) (make element gi: "tr" (make element gi: "th" attributes: '(("colspan" "2") ("align" "left")) (process-children)) ) ) (element varlistentry (let ((terms (select-elements (children (current-node)) (normalize "term"))) (listitem (select-elements (children (current-node)) (normalize "listitem")))) (make element gi: "tr" attributes: '(("valign" "top")) (make sequence (make element gi: "th" attributes: '(("align" "right")) (if (attribute-string (normalize "id")) (make element gi: "A" attributes: (list (list "NAME" (attribute-string (normalize "id")))) (process-node-list terms)) (process-node-list terms))) (make element gi: "td" (process-node-list listitem) ) ) ) ) ) (element (varlistentry term) (make sequence (process-children-trim) (if (not (last-sibling?)) (literal ", ") (literal "")))) (element (varlistentry listitem) (process-children)) ;; by copy of the index building stuff. (define (htmlindexattr-inherited attr) (if (inherited-attribute-string (normalize attr)) (make sequence (make formatting-instruction data: attr) (make formatting-instruction data: " ") (make formatting-instruction data: (inherited-attribute-string (normalize attr))) (htmlnewline)) (empty-sosofo))) (mode htmlindex ;; this mode is really just a hack to get at the root element (root (process-children)) (default (if (node-list=? (current-node) (sgml-root-element)) (make entity system-id: (html-entity-file html-index-filename) (process-node-list (select-elements (descendants (current-node)) (normalize "indexterm")))) (empty-sosofo))) (element indexterm (let* ((target (ancestor-member (current-node) (append (book-element-list) (division-element-list) (component-element-list) (section-element-list)))) (title (string-replace (element-title-string target) " " " "))) (make sequence (make formatting-instruction data: "INDEXTERM ") (make formatting-instruction data: (href-to target)) (htmlnewline) (make formatting-instruction data: "INDEXPOINT ") (make formatting-instruction data: (href-to (current-node))) (htmlnewline) (make formatting-instruction data: "TITLE ") (make formatting-instruction data: title) (htmlnewline) (htmlindexattr "scope") (htmlindexattr "significance") (htmlindexattr "class") (htmlindexattr-inherited "id") (htmlindexattr "startref") (if (attribute-string (normalize "zone")) (htmlindexzone (attribute-string (normalize "zone"))) (empty-sosofo)) (process-children) (make formatting-instruction data: "/INDEXTERM") (htmlnewline)))) (element primary (htmlindexterm)) (element secondary (htmlindexterm)) (element tertiary (htmlindexterm)) (element see (htmlindexterm)) (element seealso (htmlindexterm)) ) ;; TeX processing support (define html-tex-filename "TeX.formulae" ) (define (tex-graphic #!optional (nd (current-node))) (let* ((format (attribute-string "format" nd)) (fileref (attribute-string "fileref" nd)) ) (if (equal? format (normalize "tex")) (make sequence (make formatting-instruction data: "@Name ") (make formatting-instruction data: (string-append image-directory "/" fileref)) (htmlnewline) (make formatting-instruction data: "@Start") (htmlnewline) (make formatting-instruction data: (data nd)) (htmlnewline) (make formatting-instruction data: "@End") (htmlnewline) ) (empty-sosofo) ) ) ) (define ($img$ #!optional (nd (current-node)) (alt #f)) ;; This function now supports an extension to DocBook. It's ;; either a clever trick or an ugly hack, depending on your ;; point of view, but it'll hold us until XLink is finalized ;; and we can extend DocBook the "right" way. ;; ;; If the entity passed to GRAPHIC has the FORMAT ;; "LINESPECIFIC", either because that's what's specified or ;; because it's the notation of the supplied ENTITYREF, then ;; the text of the entity is inserted literally (via Jade's ;; read-entity external procedure). ;; (let* ((fileref (attribute-string (normalize "fileref") nd)) (entityref (attribute-string (normalize "entityref") nd)) (format (if (attribute-string (normalize "format") nd) (attribute-string (normalize "format") nd) (if entityref (entity-notation entityref) #f))) (align (attribute-string (normalize "align") nd))) (if (or fileref entityref) (if (equal? format (normalize "linespecific")) (if fileref (include-file fileref) (include-file (entity-generated-system-id entityref))) (if (equal? format (normalize "tex")) (if fileref ($graphic$ (string-append image-directory "/" fileref) format alt align) ($graphic$ (string-append image-directory "/" (system-id-filename entityref)) format alt align)) (if fileref ($graphic$ fileref format alt align) ($graphic$ (system-id-filename entityref) format alt align))) ) (empty-sosofo) ))) (mode tex-graphics ;; this mode is really just a hack to get at the root element (root (process-children)) (default (if (node-list=? (current-node) (sgml-root-element)) (make entity system-id: (html-entity-file html-tex-filename) (process-node-list (select-elements (descendants (current-node)) (normalize "graphic"))) (process-node-list (select-elements (descendants (current-node)) (normalize "inlinegraphic"))) ) (empty-sosofo))) (element graphic (tex-graphic) ) (element inlinegraphic (tex-graphic) ) ) (root (make sequence ; (literal ; (debug (node-property 'gi ; (node-property 'document-element (current-node))))) ;(define (docelem node) ; (node-propety 'document-element ; (node-property 'grove-root node))) (process-children) (with-mode manifest (process-children)) (if html-index (with-mode htmlindex (process-children)) (empty-sosofo)) (with-mode tex-graphics (process-children) ) ) ) ;; Sections can pass on role information (define ($section-body$) (let* ((sect (current-node)) (class (or (attribute-string "ROLE" sect) (gi sect) ) ) ) (make element gi: "DIV" attributes: (list (list "CLASS" class)) ($section-separator$) ($section-title$) (if (equal? class "entry") (make element gi: "blockquote" (process-children) ) (process-children) ) ) ) ) (define ($section-title$) (let* ((sect (current-node)) (info (info-element)) (subtitles (select-elements (children info) (normalize "subtitle"))) (renderas (inherited-attribute-string (normalize "renderas") sect)) (hlevel ;; the apparent section level; (if renderas ;; if not real section level, (string->number ;; then get the apparent level (substring renderas 4 5)) ;; from "renderas", (SECTLEVEL))) ;; else use the real level (h1elem (string-append "H" (number->string hlevel))) (h2elem (string-append "H" (number->string (+ hlevel 1)))) (name (element-id)) (isep (gentext-intra-label-sep (gi sect))) (nsep (gentext-label-title-sep (gi sect))) (role (attribute-string "ROLE" sect)) (h1class (if role (string-append (gi sect) "" role) (gi sect))) ) (make sequence (make element gi: h1elem attributes: (list (list "CLASS" h1class)) (make element gi: "A" attributes: (list (list "NAME" name)) (if (string=? (element-label (current-node)) "") (empty-sosofo) (literal (element-label (current-node)) nsep)) (element-title-sosofo sect) )) (if (node-list-empty? subtitles) (empty-sosofo) (with-mode subtitle-mode (make element gi: h2elem attributes: (list (list "CLASS" (string-append h1class "-subtitle"))) (process-node-list subtitles)))) ($proc-section-info$ info)))) (define %html-header-tags% '( ("link" ("rel" "stylesheet") ("type" "text/css") ("href" "cstrdoc.css")) ) ) (element synopsis (make element gi: "table" attributes: '(("cellspacing" "0")("cellpadding" "0") ("class" "synopsys")) (make element gi: "tr" (make sequence (make element gi: "td" attributes: '(("valign" "top")) (with-mode synopsis-table (process-matching-children '("synopsis" ("role" "type")))) ) (make element gi: "td" attributes: '(("valign" "top")) (with-mode synopsis-table (process-matching-children '("synopsis" ("role" "name")))) ) (with-mode synopsis-table-args (process-matching-children '("synopsis" ("role" "args")))) ) ) ) ) (mode synopsis-table-args (element synopsis (let* ((role (attribute-string "role")) (children (children (current-node))) (start (if (node-list-empty? children) "" (data (node-list-first children)))) ) (if (and (string? start) (not (string=? start ""))) (make sequence (make element gi: "td" attributes: '(("valign" "top")) (make element gi: "tt" (literal "(") ) ) (make element gi: "td" attributes: '(("valign" "top")) (make element gi: "tt" (if (and (equal? role "args") (string? start) (not (string=? start "")) (equal? (substring start 0 1) "(") ) (make sequence (literal (substring start 1 (string-length start))) (process-node-list (node-list-rest children)) ) (process-children) ) ) ) ) (empty-sosofo) ) ) ) ) (mode synopsis-table (element synopsis (make element gi: "tt" (let* ((role (attribute-string "role")) (children (children (current-node))) (start (if (node-list-empty? children) "" (data (node-list-first children)))) ) (if (and (equal? role "args") (string? start) (not (string=? start "")) (equal? (substring start 0 1) "(") ) (make sequence (literal (substring start 1 (string-length start))) (process-node-list (node-list-rest children)) ) (process-children) ) ) ) ) ) (element link (let* ((endterm (attribute-string (normalize "endterm"))) (linkend (attribute-string (normalize "linkend"))) (target (element-with-id linkend)) (etarget (if endterm (element-with-id endterm) (empty-node-list)))) (if (node-list-empty? target) (if %missing-link-error% (error (string-append "Link to missing ID '" linkend "'")) (make element gi: "font" attributes: '(("color" "green")) (process-children) ) ) (make sequence (if (and endterm (node-list-empty? etarget)) (error (string-append "EndTerm to missing ID '" endterm "' on Link")) (empty-sosofo)) (make element gi: "A" attributes: (list (list "HREF" (href-to target))) (if endterm (with-mode xref-endterm-mode (process-node-list etarget)) (process-children))))))) (element formalpara (make element gi: "DL" attributes: (list (list "CLASS" (gi))) (make element gi: "dt" (process-children)))) (element (formalpara title) (make element gi: "DT" (make element gi: "strong" (process-children))) ) (element (formalpara para) (make element gi: "DD" (process-children))) (element filename (make element gi: "TT" attributes: '(("CLASS" "filename")) (process-children)) ) (define (chunk? #!optional (nd (current-node))) ;; 1. The (sgml-root-element) is always a chunk. ;; 2. If nochunks is #t or the dbhtml PI on the root element ;; specifies chunk='no', then the root element is the only ;; chunk. ;; 3. Otherwise, elements in the chunk-element-list are chunks ;; unless they're combined with their parent. ;; 3a. Things tagged with `newpage' are chunks. ;; 4. Except for bibliographys, which are only chunks if they ;; occur in book. ;; (let ((maybechunk (or (not (equal? (gi nd) (normalize "bibliography"))) (equal? (gi (parent nd)) (normalize "book"))))) (if (node-list=? nd (sgml-root-element)) #t (if (or nochunks (equal? (dbhtml-value (sgml-root-element) "chunk") "no")) #f (if (member (gi nd) (chunk-element-list)) (if (combined-chunk? nd) #f maybechunk) (if (attribute-string "newpage" nd) maybechunk #f))))))