summaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/package/Makefile.am2
-rw-r--r--src/guile/skribilo/package/web-book2.scm124
2 files changed, 125 insertions, 1 deletions
diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am
index d6c0a28..191b102 100644
--- a/src/guile/skribilo/package/Makefile.am
+++ b/src/guile/skribilo/package/Makefile.am
@@ -3,7 +3,7 @@ dist_module_DATA = acmproc.scm french.scm jfp.scm letter.scm \
lncs.scm scribe.scm sigplan.scm \
slide.scm web-article.scm web-book.scm \
eq.scm pie.scm base.scm diff.scm \
- html-navtabs.scm
+ html-navtabs.scm web-book2.scm
SUBDIRS = slide eq pie
diff --git a/src/guile/skribilo/package/web-book2.scm b/src/guile/skribilo/package/web-book2.scm
new file mode 100644
index 0000000..978d012
--- /dev/null
+++ b/src/guile/skribilo/package/web-book2.scm
@@ -0,0 +1,124 @@
+;;; web-book2.scm -- Another web book style.
+;;;
+;;; Copyright 2008 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;;
+;;; 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-module (skribilo package web-book2)
+ :use-module (skribilo ast)
+ :use-module (skribilo engine)
+ :use-module (skribilo package base)
+
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords)
+
+ :use-module (srfi srfi-1)
+
+ :replace (chapter section subsection subsubsection))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Another variant of the web book publishing. This module is purely
+;;; functional, i.e., unlike `web-book', it doesn't modify the HTML engine
+;;; customs or writers. Instead, it replaces the `chapter' and
+;;; `(sub)*section' markups with variants that produce a small table of
+;;; contents at the beginning of new files.
+;;;
+;;; Code:
+
+
+;;;
+;;; Small table-of-contents.
+;;;
+
+(define (section? n)
+ (and (container? n)
+ (memq (markup-markup n)
+ '(chapter section subsection subsubsection))))
+
+(define (make-small-toc n)
+ ;; Return a small table of contents, for use at the beginning of chapter N.
+ (define (make-uplink)
+ (let ((parent (ast-parent n)))
+ (and parent
+ (ref :handle (handle parent)
+ :text (list "<< up to ``"
+ (markup-option parent :title)
+ "''")))))
+
+ (let ((kids (filter section? (markup-body n))))
+ (p :class "small-toc"
+ (list
+ (and (not (null? kids))
+ (list "Table of Contents"
+ (itemize
+ (map (lambda (section)
+ (item (ref :handle (handle section)
+ :text (markup-option section :title))))
+ kids))))
+ (make-uplink)))))
+
+
+(define (in-file-of-its-own? n e)
+ ;; Return true if node N is in an HTML file of its own.
+ (and (engine-format? "html" e)
+ (section? n)
+ (or (markup-option n :file)
+ (let ((custom (symbol-append (markup-markup n) '-file)))
+ (engine-custom e custom)))))
+
+
+;;;
+;;; Overrides.
+;;;
+
+(define %base-package
+ (resolve-interface '(skribilo package base)))
+
+(define (make-overriding-markup markup)
+ ;; Override the `chapter' markup from the `base' package to allow the
+ ;; production of a small TOC at the beginning of each chapter.
+ (let ((real-markup (module-ref %base-package markup)))
+ (lambda args
+ ;;(format (current-error-port) "in new `~a'~%" markup)
+ (if (engine-format? "html")
+ (apply real-markup
+ (append (concatenate (the-options args))
+ (cons (resolve (lambda (n e env)
+ (let ((p (ast-parent n)))
+ (and (in-file-of-its-own? p e)
+ (make-small-toc p)))))
+ (the-body args))))
+ (apply real-markup args)))))
+
+(define chapter
+ (make-overriding-markup 'chapter))
+
+(define section
+ (make-overriding-markup 'section))
+
+(define subsection
+ (make-overriding-markup 'subsection))
+
+(define subsubsection
+ (make-overriding-markup 'subsubsection))
+
+;;; web-book2.scm ends here