1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
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
|
