Newer
Older
#+xcvb
(module
(:depends-on
("fare-utils"
"fare-matcher"
"scribble"
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
"exscribe/packages"
"exscribe/macros"
"exscribe/specials"
"exscribe/exscribe-data"
"exscribe/bibliography"
"exscribe/html-dumper")))
(in-package :exscribe-html)
#| "
:author (name url) => proper HTML header, footer, etc.
:ref (bib ...) => bibliographic reference, section reference...
:footnote (note) => list of footnotes
:table-of-contents (section subsection subsubsection) => XXX
:section (number title)
:subsection (number title)
:subsubsection (number title)
" |#
(defun sc (&rest x)
(apply 'span :style "font-variant: small-caps" x))
(defun make-title (&key title author)
(when title
(table :width "100%"
(tr (td :bgcolor *title-background* :align 'center
(font :color *foreground*
:face "sans-serif" :size "10" (bold title))
(when author (*list (br) author)))))))
(defun make-author (&key name email affiliation url)
(declare (ignore email))
(center
(br*
(when name (font :size "+3" (it name)))
(when affiliation (font :size "+1" affiliation))
(when url (font :size "+1"
(tt (if (stringp url) (a :href url url) url)))))))
(defun edited-footnote (note num)
(list
(a :name (format nil "footnote~A" num))
(a :href (format nil "#footnoteref~A" num) "[" num "]") ": "
note))
(defun find-first-paragraph (x)
(labels
((fail ()
(return-from find-first-paragraph nil))
(walk (x)
(match x
((tag :p * *) x)
((tag :id * x) (walk x))
((tag * * *) (fail))
((of-type string) (fail))
((cons x y) (or (walk x) (walk y)))
(* nil))))
(walk x)))
(defun edit-footnote (note num)
(aif (find-first-paragraph note)
(prog1 note
(push (edited-footnote nil num) (tag-contents it)))
(p :align 'justify (edited-footnote note num))))
(defun make-footnote (note)
(let* ((num (incf *footnote-counter*))
(editednote (edit-footnote note num)))
(push editednote *footnotes*)
(id
(a :name (format nil "footnoteref~A" num))
(a :href (format nil "#footnote~A" num) (sup (small #\[ num #\]))))))
(defun title-font (&rest x)
(font :size "+1" :face "sans-serif" (apply 'bold x)))
(defun generate-label ()
(format nil "G~3,'0D" (incf *generate-label-counter*)))
(defun make-xsection (type indent options index display)
(let* ((title (getf options :title))
(toc (getf options :toc t))
(toc-text (if index
(id index (when title #\space) title)
title))
(label (or (getf options :label)
(and (stringp title) title)))
(tag (or index (generate-label)))
(name (format nil "~A_~A" type tag))
(hname (strcat "#" name)))
(when toc
(push (cons type (id indent (a :href hname toc-text))) *toc*))
(when label
(setf (gethash label *sections-by-label*) (cons hname title)))
(id (a :name name) (funcall display toc-text))))
(defun make-section (options)
(let ((number (getf options :number t)))
(when (eq number t) (setf number (incf *section-counter*)))
(setf *section-name* number
*subsection-counter* 0 *subsubsection-counter* 0)
(make-xsection :section nil options number
#'(lambda (x)
(table :width "100%"
(tr (td :bgcolor *section-title-background* :valign :top
(title-font x))))))))
(defun make-subsection (options)
(let ((number (getf options :number t)))
(when (eq number t)
(setf number (format nil "~@[~A.~]~A"
*section-name*
(incf *subsection-counter*))))
(setf *subsection-name* number *subsubsection-counter* 0)
(make-xsection :subsection " " options number #'title-font)))
(defun make-subsubsection (options)
(let ((number (getf options :number t)))
(when (eq number t)
(setf number (format nil "~@[~A.~]~A"
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
*subsection-name*
(incf *subsubsection-counter*))))
(setf *subsubsection-name* number)
(make-xsection :subsubsection " "
options number
#'(lambda (x) (p :align 'left (bold x) " ")))))
(defun compute-toc (toc sec subsec subsubsec)
(setf (tag-contents toc)
(*list
(brlist
(loop for (ct . c) in *toc* collect
(case ct
(:section (when sec c))
(:subsection (when (and sec subsec) c))
(:subsubsection (when (and sec subsec subsubsec) c))
(t nil)))))))
(defun make-toc (&key (section t) (subsection t) (subsubsection t) &aux (toc (id)))
(push #'(lambda () (compute-toc toc section subsection subsubsection))
*postprocess-hooks*)
toc)
(defun bib-ref-name (bibent)
;;; add more styles later
;;; it's ugly to use :ident instead of B and :index
(id "[B" (gethash :index bibent) "]"))
(defun compute-bib-ref (doc bibent)
(copy-tag doc
(a :href (format nil "#bibent-~A" (gethash :ident bibent))
(bib-ref-name bibent))))
(defun prepare-bib-ref (doc entry)
(let ((bibent (get-bib-entry entry doc)))
(push #'(lambda () (compute-bib-ref doc bibent))
*postprocess-hooks*)))
(defun show-bib-entry (e)
(let* ((f (gethash :fields e))
(title (gethash 'title f))
(ititle (it title))
(author (gethash 'author f))
(year (gethash 'year f))
(url (gethash 'url f)))
(id
(a :name (format nil "bibent-~A" (gethash :ident e)))
(bib-ref-name e) #\space
(if url (a :href url ititle) ititle)
(when author (id ", " author))
(when year (id ", " year)))))
(defun display-bibliography (entries)
(*list
*bibliography-header*
(brlist (mapcar 'show-bib-entry entries))))
(defun postprocess-document ()
(let ((fnotes (id)))
(setf *document*
(list 'list *header* *document* fnotes *footer*))
(walking-document (doc *document*)
(match doc
((tag :ref (list :url url) body)
(replace-tag! doc :a (list :href url) body)
(walk doc))
((tag :ref (list :bib entry) list)
(unless (null list) (error "bad bib ref ~A" doc))
(prepare-bib-ref doc entry))
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
((tag :document options list)
(replace-tag! doc :id ()
`(,@(when options (list (apply #'make-title options)))
,@list))
(walk doc))
((tag :author options list)
(replace-tag! doc :id ()
`(,@(when options (list (apply #'make-author options)))
,@list))
(walk doc))
((tag :footnote (list :note note) list)
(let ((fnote (id)))
(replace-tag! doc :id () (append list (list fnote)))
(walk doc)
(setf (tag-contents fnote) (list (make-footnote note)))
(walk note)))
((vector :section options list)
(replace-tag! doc :id () (cons (make-section options) list))
(walk doc))
((vector :subsection options list)
(replace-tag! doc :id () (cons (make-subsection options) list))
(walk doc))
((vector :subsubsection options list)
(replace-tag! doc :id () (cons (make-subsubsection options) list))
(walk doc))
((vector :table-of-contents options list)
(replace-tag! doc :id () (cons (apply #'make-toc options) list))
(walk doc))
(* (walk doc))))
;; Another pass for internal references, after all sections are indexed.
(walking-document (doc *document*)
(match doc
((tag :ref (list :section section) body)
(let* ((section-data (gethash section *sections-by-label*))
(hname (car section-data))
(title (cdr section-data)))
(replace-tag! doc :a (list :href hname) (or body (list title)))))
(setf *toc* (nreverse *toc*))
(when *footnotes*
(setf (tag-contents fnotes)
(cons (id (hrule) (h4 *footnotes-title*))
(reverse *footnotes*))))
(apply #'process-bibliography
:display #'display-bibliography
*bibliography-options*)
(dolist (h (reverse *postprocess-hooks*))
(funcall h))
t))
(defun dump-document ()
(html-dumper:html *document* *standard-output*)
t)
(defun process-document ()
(xxtime ("<== Postprocessing the document~%")
(postprocess-document))
(xxtime ("<== Dumping the document~%")
(dump-document)))
(defun init ()
(setf scribble:*scribble-preprocess* nil
;; scribble:*scribble-preprocess* t
;; scribble:*scribble-preprocessor* #'html-dumper:html-escape
*exscribe-document-hook* 'process-document))