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
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
190
191
192
193
194
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
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
| #lang racket/base
; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.
;; Tag functions used by pollen.rkt when HTML is the output format.
(require (for-syntax racket/base racket/syntax))
(require racket/list
racket/function
racket/draw
racket/class
pollen/decode
pollen/tag
pollen/setup
net/uri-codec
txexpr
"dust.rkt")
(provide html-fn
html-fndef)
;; Customized paragraph decoder replaces single newlines within paragraphs
;; with single spaces instead of <br> tags. Allows for “semantic line wrapping”.
(define (decode-hardwrapped-paragraphs xs)
(define (no-linebreaks xs)
(decode-linebreaks xs " "))
(decode-paragraphs xs #:linebreak-proc no-linebreaks))
;; A shortcut macro: lets me define a whole lot of tag functions of the form:
;; (define html-p (default-tag-function 'p)
(define-syntax (provide/define-html-default-tags stx)
(syntax-case stx ()
[(_ TAG ...)
(let ([tags (syntax->list #'(TAG ...))])
(with-syntax ([((HTML-TAG-FUNC HTML-TAG) ...)
(for/list ([htag (in-list tags)])
(list (format-id stx "html-~a" (syntax-e htag)) (syntax-e htag)))])
#'(begin
(provide HTML-TAG-FUNC ...)
(define HTML-TAG-FUNC (default-tag-function 'HTML-TAG)) ...)))]))
;; Here we go:
(provide/define-html-default-tags p
b
strong
i
em
ol
ul
sup
blockquote
code)
(provide html-root
html-item
html-section
html-subsection
html-newthought
html-caps
html-center
html-strike
html-block
html-blockcode
html-index
html-figure
html-figure-@2x
html-image-link
html-dialogue
html-say
html-saylines
html-verse
html-link
html-url
html-fn
html-fndef
html-note)
(define html-item (default-tag-function 'li))
(define html-section (default-tag-function 'h2))
(define html-subsection (default-tag-function 'h3))
(define html-newthought (default-tag-function 'span #:class "newthought"))
(define html-caps (default-tag-function 'span #:class "caps"))
(define html-center (default-tag-function 'div #:style "text-align: center"))
(define html-strike (default-tag-function 'span #:style "text-decoration: line-through"))
(define html-dialogue (default-tag-function 'dl #:class "dialogue"))
(define (html-block . elements)
`(section [[class "content-block"]] (div [[class "content-block-main"]] ,@elements)))
(define (html-root . elements)
(invalidate-series)
(define first-pass
(decode-elements (append elements (list (html-footnote-block)))
#:txexpr-elements-proc decode-hardwrapped-paragraphs
#:exclude-tags '(script style figure table pre)))
(define second-pass
(decode-elements first-pass
#:block-txexpr-proc detect-newthoughts
#:inline-txexpr-proc decode-link-urls
#:exclude-tags '(script style pre code)))
`(body ,@second-pass))
(define (html-blockcode attrs elems)
(define file (or (assoc 'filename attrs) ""))
(define codeblock `(pre [[class "code"]] (code ,@elems)))
(cond [(string>? file "") `(@ (div [[class "listing-filename"]] 128196 " " ,file) ,codeblock)]
[else codeblock]))
(define (html-index attrs elems)
(define index-key (maybe-attr 'key attrs (tx-strs `(span ,@elems))))
`(a [[id ,(here-id (list "_idx-" (uri-encode index-key)))]
[href ,(string-append "/keyword-index.html#" (uri-encode (string-downcase index-key)))]
[data-index-entry ,index-key]
[class "index-link"]]
,@elems))
;; To be used within ◊dialogue
(define (html-say . elems)
`(@ (dt ,(car elems) (span [[class "x"]] ": ")) (dd ,@(cdr elems))))
;; Same as ◊say, but preserve linebreaks
(define (html-saylines . elems)
(apply html-say (decode-linebreaks elems)))
(define (html-verse attrs elems)
(let* ([title (maybe-attr 'title attrs "")]
[italic? (assoc 'italic? attrs)]
[pre-attrs (cond [italic? '([class "verse"] [style "font-style: italic"])]
[else '([class "verse"])])]
[pre-title (cond [(string>? title "") `(p [[class "verse-heading"]] ,title)]
[else ""])])
`(div [[class "poem"]] ,pre-title (pre ,pre-attrs ,@elems))))
;; (Private) Get the dimensions of an image file
(define (get-image-size filepath)
(define bmp (make-object bitmap% filepath))
(list (send bmp get-width) (send bmp get-height)))
;; (Private) Builds a path to an image in the [image-dir] subfolder of the current document's
;; folder, relative to the current document’s folder
(define (image-source basename)
(define here-path (string->path (maybe-meta 'here-path)))
(define-values (_ here-rel-path-parts)
(drop-common-prefix (explode-path (current-project-root))
(explode-path here-path)))
(let* ([folder-parts (drop-right here-rel-path-parts 1)]
[img-path-parts (append folder-parts (list images-folder basename))]
[img-path (apply build-path/convention-type 'unix img-path-parts)])
(path->string img-path)))
(define (html-figure-@2x . elems)
(define src (image-source (car elems)))
(define alt-text (tx-strs `(span ,@(cdr elems))))
(define img-width (car (get-image-size (build-path (current-project-root) src))))
(define style-str (format "width: ~apx" (/ img-width 2.0)))
`(figure (img [[alt ,alt-text] [style ,style-str] [src ,(string-append web-root src)]])
(figcaption ,@(cdr elems))))
(define (html-figure . elems)
(define src (string-append web-root (image-source (car elems))))
(define alt-text (tx-strs `(span ,@(cdr elems))))
`(figure [[class "fullwidth"]]
(img [[alt ,alt-text] [src ,src]])
(figcaption ,@(cdr elems))))
;; Simple link to an image
(define (html-image-link . elems)
(define src (image-source (car elems)))
(define title (tx-strs `(span ,@(cdr elems))))
`(a [[href ,(string-append web-root src)] [title ,title]] ,@(cdr elems)))
;; There is no way in vanilla CSS to create a selector for “p tags that contain
;; a span of class ‘newthought’”. So we can handle it at the Pollen processing level.
(define (detect-newthoughts block-xpr)
(define (is-newthought? tx) ; Helper function
(and (txexpr? tx)
(eq? 'span (get-tag tx))
(attrs-have-key? tx 'class)
(string=? "newthought" (attr-ref tx 'class))))
(if (and (eq? (get-tag block-xpr) 'p)
(is-newthought? (first (get-elements block-xpr))))
(attr-set block-xpr 'class "pause-before")
block-xpr))
;; Links
;;
;; Private use:
(define link-urls (make-hash))
;; Provided tag functions:
(define (html-link . args)
`(link& [[ref ,(format "~a" (first args))]] ,@(rest args)))
(define (html-url ref url)
(hash-set! link-urls (format "~a" ref) url) "")
;; Private use (by html-root):
(define (decode-link-urls tx)
(cond [(eq? (get-tag tx) 'link&)
(let* ([url-ref (attr-ref tx 'ref)]
[url (or (hash-ref link-urls url-ref #f)
(format "Missing reference: ~a" url-ref))])
`(a [[href ,url]] ,@(get-elements tx)))]
[else tx]))
;; Footnotes
;;
;; Private use:
(define fn-names null)
(define fn-definitions (make-hash))
(define (fn-id x) (here-id (string-append x "_fn")))
(define (fndef-id x) (here-id (string-append x "_fndef")))
;; Provided footnote tag functions:
(define (html-fn . args)
(define name (format "~a" (first args)))
(set! fn-names (cons name fn-names))
(let* ([def-anchorlink (string-append "#" (fndef-id name))]
[nth-ref (number->string (count (curry string=? name) fn-names))]
[ref-id (string-append (fn-id name) nth-ref)]
[fn-number (+ 1 (index-of (remove-duplicates (reverse fn-names)) name))]
[ref-text (format "(~a)" fn-number)])
(cond [(empty? (rest args)) `(sup (a [[href ,def-anchorlink] [id ,ref-id]] ,ref-text))]
[else `(span [[class "links-footnote"] [id ,ref-id]]
,@(rest args)
(sup (a [[href ,def-anchorlink]] ,ref-text)))])))
(define (html-fndef . elems)
(hash-set! fn-definitions (format "~a" (first elems)) (rest elems)))
;; Private use (by html-root)
(define (html-footnote-block)
(define note-items
(for/list ([fn-name (in-list (remove-duplicates (reverse fn-names)))])
(let* ([definition-text (or (hash-ref fn-definitions fn-name #f)
'((i "Missing footnote definition!")))]
[backref-count (count (curry string=? fn-name) fn-names)]
[backrefs (for/list ([fnref-num (in-range backref-count)])
`(a [[href ,(string-append "#"
(fn-id fn-name)
(format "~a" (+ 1 fnref-num)))]] "↩"))])
`(li [[id ,(fndef-id fn-name)]] ,@definition-text ,@backrefs))))
(cond [(null? note-items) ""]
[else `(section ((class "footnotes")) (hr) (ol ,@note-items))]))
(define (html-note attrs elems)
(txexpr 'note attrs (decode-hardwrapped-paragraphs elems)))
|
