#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-smallcaps
html-center
html-strike
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
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-smallcaps (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))
(define (html-say . elems)
`(@ (dt ,(car elems) (span [[class "x"]] ": ")) (dd ,@(cdr 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))))
;; 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)))
