#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 pollen/decode pollen/tag net/uri-codec txexpr "dust.rkt") (provide html-fn html-fndef) ;; Customized paragraph decoder replaces single newlines within paragraphs ;; with single spaces instead of
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 strike ol ul sup blockquote code) (provide html-root html-item html-section html-subsection html-newthought html-smallcaps html-center html-block html-blockcode html-index 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 "smallcaps")) (define html-center (default-tag-function 'div #:style "text-align: center")) (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 #:string-proc (compose1 smart-quotes smart-dashes) #: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 . elems) `(a [[id ,(here-id (list "_idx-" (uri-encode (car elems))))] [href ,(string-append "/keyword-index.html#" (uri-encode (string-downcase (car elems))))] [data-index-entry ,(car elems)] [class "index-link"]] ,@(cdr 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)))) ;; 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) (string-append x "_fn")) (define (fndef-id x) (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)))