@@ -1,313 +1,112 @@ #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 - pollen/core - 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 [[class "sep"]])) -(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 all-link-urls (make-hash)) - -;; Provided tag functions: -(define (html-link . args) - `(link& [[ref ,(format "~a" (first args))]] ,@(rest args))) - -(define (html-url ref url) - (define page-path (hash-ref (current-metas) 'here-path)) - (define page-link-urls (hash-ref! all-link-urls page-path make-hash)) - (hash-set! page-link-urls (format "~a" ref) url) "") - -;; Private use (by html-root): -(define (decode-link-urls tx) - (define page-path (hash-ref (current-metas) 'here-path)) - (define page-link-urls (hash-ref! all-link-urls page-path make-hash)) - (cond [(eq? (get-tag tx) 'link&) - (let* ([url-ref (attr-ref tx 'ref)] - [url (or (hash-ref page-link-urls url-ref #f) - (format "Missing reference: ~a" url-ref))]) - `(a [[href ,url]] ,@(get-elements tx)))] - [else tx])) - -;; Fast link to another article -(define html-xref - (case-lambda - [(title) `(a [[href ,(format "~aarticles/~a.html" web-root (normalize title))] - [class "xref"]] - (i ,title))] - [elems `(a [[href ,(format "~aarticles/~a.html" web-root (first elems))] - [class "xref"]] - ,@(rest elems))])) - -;; Footnotes -;; -;; Private use: -(define all-fn-names (make-hash)) -(define all-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))) - (define page-path (hash-ref (current-metas) 'here-path)) - (define page-fn-names (cons name (hash-ref! all-fn-names page-path '()))) - (hash-set! all-fn-names page-path page-fn-names) - - (let* ([def-anchorlink (string-append "#" (fndef-id name))] - [nth-ref (number->string (count (curry string=? name) page-fn-names))] - [ref-id (string-append (fn-id name) nth-ref)] - [fn-number (+ 1 (index-of (remove-duplicates (reverse page-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) - (define page-path (hash-ref (current-metas) 'here-path)) - (define page-fn-defs (hash-ref! all-fn-definitions page-path make-hash)) - (hash-set! page-fn-defs (format "~a" (first elems)) (rest elems))) - -;; Private use (by html-root) -(define (html-footnote-block) - (define page-path (hash-ref (current-metas) 'here-path)) - (define page-fn-names (hash-ref! all-fn-names page-path '())) - (define page-fn-defs (hash-ref! all-fn-definitions page-path (make-hash))) - (define note-items - (for/list ([fn-name (in-list (remove-duplicates (reverse page-fn-names)))]) - (let* ([definition-text (or (hash-ref page-fn-defs fn-name #f) - '((i "Missing footnote definition!")))] - [backref-count (count (curry string=? fn-name) page-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))) +;; Pollen “tag functions” that return elements of a Yarn AST. This AST can be +;; rendered into HTML or other formats (using, e.g., the yarn/render/html module). + +(require pollen/decode + pollen/tag + "index.rkt" + "string.rkt" + "tools.rkt") + +(provide (all-defined-out)) + +;; Yarn AST: +;; (document Block-Contents) +;; Footnote definitions, index entry keys are stored in the metas + +;; Block-Content := +;; (heading #:level Inline-Contents) +;; | (paragraph Inline-Contents) +;; | (thematic-break style) +;; | (codeblock info Inline-Contents) +;; | (blockquote items := (item Block-Contents)) +;; | (poetry title style Block-Contents) +;; | (itemization style start Block-Contents) +;; | (dialogue speeches := (speech interlocutor Block-Contents)) +;; | (figure source caption) +;; | (margin-note Block-Contents) + +;; Inline-Content := +;; string? +;; | (italic Inline-Contents) +;; | (bold Inline-Contents) +;; | (link destination Inline-Contents) +;; | (monospace Inline-Contents) +;; | (strikethrough Inline-Contents) +;; | (caps Inline-Contents) +;; | (image description source) +;; | (xref type dest-key Inline-Contents) +;; | (footnote-ref label) +;; | line-break + +(define blocks-elements + '(heading + paragraph + thematic-break + codeblock + blockquote + poetry + itemization + dialogue + figure + margin-note)) + +(define inline-elements + '(italic + bold + link + image + xref + footnote-ref + line-break)) + +(define (title . t) (set-meta 'title t) (set-meta 'title-supplied? #t) "") +(define (section . s) `(heading [[level "2"]] ,@s)) +(define (subsection . s) `(heading [[level "3"]] ,@s)) +(define (excerpt . e) (set-meta 'excerpt e)) +(define (excerpt* . e) (apply excerpt e) `(@ ,@e)) + +(define (pause [type 'blank]) `(thematic-break ,type)) ; type = blank | mark + +(define codeblock (default-tag-function 'codeblock #:info "")) +(define blockquote (default-tag-function 'blockquote)) ; #:caption +(define figure (default-tag-function 'figure)) + +(define (i . inline) `(italic ,@inline)) +(define em i) +(define (b . inline) `(bold ,@inline)) +(define (mono . inline) `(monospace ,@inline)) +(define (caps . inline) `(caps ,@inline)) +(define (strike . inline) `(strikethrough ,@inline)) +(define br 'line-break) + +(define (link ref . elems) `(link ,ref ,@elems)) +(define (url ref URL) (update-metas-subhash 'urls ref URL) "") + +(define (xref type elems k) + (define key (or k (normalize-key (->text elems)))) + (cons-to-metas-list 'xref-keys key) + `(xref ,type ,key ,@elems)) + +(define (pin #:key [key #f] . elems) (xref 'idx elems key)) +(define (def #:key [key #f] . elems) (xref 'def elems key)) +(define (ref #:key [key #f] . elems) (xref 'ref elems key)) + +(define (fn ref) `(footnote-ref ,ref)) +(define (fndef ref . elems) (update-metas-subhash 'footnote-defs ref elems) "") + +(define (ol . elems) `(itemization [[start "1"]] ,@elems)) ; #:style +(define (ul . elems) `(itemization ,@elems)) ; #:style +(define (item . blocks) `(item ,@blocks)) + +(define (dialogue . speeches) `(dialogue ,@speeches)) +(define (say interlocutor elems) `(speech ,interlocutor ,@elems)) +(define (saylines interlocutor elems) + `(speech ,interlocutor ,@(decode-linebreaks elems 'line-break))) + +(define verse (default-tag-function 'poetry)) ; #:title, #:style +