#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
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-title html-excerpt html-excerpt* html-item html-section html-subsection html-newthought html-sep html-caps html-mono 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-magick html-verse html-attrib html-link html-xref html-url html-fn html-fndef html-note-with-srcline) (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-sep) '(hr)) (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-mono (default-tag-function 'samp)) (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-title . elements) `(title ,@elements)) (define (html-excerpt . elements) `(excerpt ,@elements)) (define (html-excerpt* . elements) `(excerpt* ,@elements)) (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)))) (define (html-magick . elems) (txexpr 'div '([class "antique"]) (decode-elements elems #:string-proc (λ (s) (regexp-replace* #px"(?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])) ;; Quick link to another article (define (html-xref . elems) `(a [[href ,(format "~aarticles/~a.html" web-root (first elems))] [class "xref"]] ,@(rest elems))) ;; 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-with-srcline attrs elems) (txexpr 'note attrs (decode-hardwrapped-paragraphs elems)))