◊(Local Yarn Code "Diff")

Differences From Artifact [fedcf631]:

To Artifact [8147764e]:


1
2
3
4
5
6
7
8
9
10


11
12

13
14
15
16
17
18
19
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22










+
+


+







#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)

28
29
30
31
32
33
34
35

36
37
38
39
40
41
42
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45







-
+







;;  (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)))])
                        (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
56
57
58
59
60
61
62


63
64
65
66
67
68
69
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74







+
+







         html-subsection
         html-newthought
         html-smallcaps
         html-center
         html-block
         html-blockcode
         html-index
         html-figure
         html-figure-@2x
         html-dialogue
         html-say
         html-verse
         html-link
         html-url
         html-fn
         html-fndef
113
114
115
116
117
118
119
































120
121
122
123
124
125
126
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







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







  (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))))

;; 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))
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191








192
193
194
195
196
214
215
216
217
218
219
220








221
222
223
224
225
226
227
228
229
230
231
232
233







-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+





(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))))
      (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)))