Index: articles/what-should-people-do-with-old-journals.poly.pm
==================================================================
--- articles/what-should-people-do-with-old-journals.poly.pm
+++ articles/what-should-people-do-with-old-journals.poly.pm
@@ -4,28 +4,30 @@
◊(define-meta published "2019-04-11")
◊title{What Should People Do With Old Journals?}
-When I die, I’ll leave behind a lot of ◊index{journals} and notebooks. These may be of
+When I die, I’ll leave behind a lot of ◊pin{journals} and notebooks. These may be of
interest to my immediate family, but they won’t exactly be great leisure reading. The only obvious
choices are to keep them in a box in the attic, or eventually throw them out.
+
+A ◊def{journal} is a collection of personal observations.
There ought to be a third choice. Even the most mundane journal has great value simply because it
contains lots of historical information about current thinking, lifestyle habits, values, and events,
things which change wildly over long time periods.
-On the receiving end, suppose you inherit your great-grandfather’s journal; he has been dead for
+◊blockquote[#:caption "hi"]{On the receiving end, suppose you inherit your great-grandfather’s journal; he has been dead for
decades and you never knew him personally. If you can find the time, you pore over it for an hour or
two, deciphering the handwriting. You learn some facts about him and how he looked at things. What
-happens after that?
+happens after that?}
-I have an idea that there should be an ◊index[#:key "archives"]{archive}, a public repository for
+I have an idea that there should be an ◊pin[#:key "archives"]{archive}, a public repository for
things like this. You could send in your great-grandfather’s journal for use by future historians.
They would digitize or transcribe it, analyze it, and tag it with metadata about who wrote it, when
they wrote it, and generally what topics they wrote about. They could allow you to specify that it
must remain private until a specified date, and provide you with a digital copy, or even a nice hard
copy if you wanted to pay a little extra.
This would give researchers a huge resource to draw upon, and allow the full value of old journals
(the sentimental ◊em{and} the historic value) to be realized, without compromising anyone’s
privacy.
ADDED pollen-old.rkt
Index: pollen-old.rkt
==================================================================
--- pollen-old.rkt
+++ pollen-old.rkt
@@ -0,0 +1,147 @@
+#lang racket/base
+
+; SPDX-License-Identifier: BlueOak-1.0.0
+; This file is licensed under the Blue Oak Model License 1.0.0.
+
+;; Functions for tags and template content used in all Pollen source files and templates.
+
+(require (for-syntax "targets.rkt"
+ racket/base
+ racket/syntax
+ syntax/parse))
+
+(require pollen/tag
+ pollen/setup
+ "cache.rkt"
+ "tags-html.rkt"
+ "snippets-html.rkt"
+ "crystalize.rkt")
+
+(provide (all-defined-out)
+ (all-from-out "crystalize.rkt" "snippets-html.rkt" "cache.rkt"))
+
+(module setup racket/base
+ (require "targets.rkt"
+ syntax/modresolve
+ racket/runtime-path
+ pollen/setup)
+ (provide (all-defined-out))
+ (define poly-targets targets)
+ (define allow-unbound-ids? #f)
+
+ (define block-tags (append '(title style dt note) default-block-tags))
+
+ (define-runtime-path tags-html.rkt "tags-html.rkt")
+ (define-runtime-path snippets-html.rkt "snippets-html.rkt")
+ (define-runtime-path dust.rkt "dust.rkt")
+ (define-runtime-path crystalize.rkt "crystalize.rkt")
+ (define-runtime-path cache.rkt "cache.rkt")
+ (define-runtime-path series-list.rkt "series-list.rkt")
+ (define cache-watchlist
+ (map resolve-module-path
+ (list tags-html.rkt
+ snippets-html.rkt
+ dust.rkt
+ cache.rkt
+ series-list.rkt
+ crystalize.rkt))))
+
+;; Macro for defining tag functions that automatically branch based on the
+;; current output format and the list of poly-targets in the setup module.
+;; Use this macro when you know you will need keyword arguments.
+;;
+(define-syntax (poly-branch-kwargs-tag stx)
+ (syntax-parse stx
+ [(_ TAG:id)
+ (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
+ (for/list ([target (in-list targets)])
+ (list target (format-id stx "~a-~a" target #'TAG)))]
+ [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
+ #'(define-tag-function (TAG attributes elems)
+ (case (current-poly-target)
+ [(POLY-TARGET) (POLY-FUNC attributes elems)] ...
+ [else (DEFAULT-FUNC attributes elems)])))]))
+
+;; Like above, but uses `define` instead of `define-tag-function`.
+;; Use this when you know you will not need keyword arguments.
+;;
+(define-syntax (poly-branch-tag stx)
+ (syntax-parse stx
+ [(_ TAG:id)
+ (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
+ (for/list ([target (in-list targets)])
+ (list target (format-id stx "~a-~a" target #'TAG)))]
+ [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
+ #'(define (TAG . args)
+ (case (current-poly-target)
+ [(POLY-TARGET) (apply POLY-FUNC args)] ...
+ [else (apply DEFAULT-FUNC args)])))]))
+
+;; Define all the tag functions
+(poly-branch-tag root)
+(poly-branch-tag title)
+(poly-branch-tag excerpt)
+(poly-branch-tag excerpt*)
+
+(poly-branch-tag p)
+(poly-branch-tag i)
+(poly-branch-tag em)
+(poly-branch-tag b)
+(poly-branch-tag mono)
+(poly-branch-tag strong)
+(poly-branch-tag strike)
+;(poly-branch-tag color)
+(poly-branch-tag ol)
+(poly-branch-tag ul)
+(poly-branch-tag item)
+(define li item) ; useful alias :-P
+(poly-branch-tag sup)
+(poly-branch-tag blockquote)
+(poly-branch-tag newthought)
+(poly-branch-tag sep)
+(poly-branch-tag caps)
+(poly-branch-tag center)
+(poly-branch-tag section)
+(poly-branch-tag subsection)
+(poly-branch-tag code)
+(poly-branch-tag dialogue)
+(poly-branch-tag say)
+(poly-branch-tag saylines)
+(poly-branch-tag magick) ; Extra-fancy ligatures, “long s”
+(poly-branch-kwargs-tag index)
+(poly-branch-tag figure)
+(poly-branch-tag figure-@2x)
+(poly-branch-tag image-link)
+(poly-branch-kwargs-tag blockcode)
+(poly-branch-kwargs-tag verse) ; [#:title ""] [#:italic "no"]
+(poly-branch-tag attrib)
+
+(poly-branch-tag link)
+(poly-branch-tag url)
+(poly-branch-tag xref)
+(poly-branch-tag fn)
+(poly-branch-tag fndef)
+
+(poly-branch-kwargs-tag note-with-srcline)
+(poly-branch-tag block)
+
+;; Not yet implemented
+; (poly-branch-tag table) ; #:columns ""
+; (poly-branch-tag inline-math)
+; (poly-branch-tag margin-note)
+; (poly-branch-tag noun)
+; (poly-branch-func index-entry entry)
+; (poly-branch-tag spot-illustration) ; #:src "img--sans-path.png" [#:has-print-version? "yes"]
+
+(define-syntax (note stx)
+ (syntax-parse stx
+ [(_ args ...)
+ (with-syntax ([srcline (number->string (syntax-line stx))])
+ #'(note-with-srcline #:srcline srcline args ...))]))
+
+;; My pet shortcut for for/splice. Greatly cuts down on parentheses for the
+;; most common use case (looping through a single list).
+(define-syntax (for/s stx)
+ (syntax-case stx ()
+ [(_ thing listofthings result-expr ...)
+ #'(for/splice ([thing (in-list listofthings)]) result-expr ...)]))
Index: pollen.rkt
==================================================================
--- pollen.rkt
+++ pollen.rkt
@@ -1,147 +1,36 @@
#lang racket/base
-; SPDX-License-Identifier: BlueOak-1.0.0
-; This file is licensed under the Blue Oak Model License 1.0.0.
-
-;; Functions for tags and template content used in all Pollen source files and templates.
-
-(require (for-syntax "targets.rkt"
- racket/base
- racket/syntax
- syntax/parse))
-
-(require pollen/tag
- pollen/setup
- "cache.rkt"
- "tags-html.rkt"
- "snippets-html.rkt"
- "crystalize.rkt")
-
-(provide (all-defined-out)
- (all-from-out "crystalize.rkt" "snippets-html.rkt" "cache.rkt"))
-
-(module setup racket/base
- (require "targets.rkt"
- syntax/modresolve
- racket/runtime-path
- pollen/setup)
- (provide (all-defined-out))
- (define poly-targets targets)
- (define allow-unbound-ids? #f)
-
- (define block-tags (append '(title style dt note) default-block-tags))
-
- (define-runtime-path tags-html.rkt "tags-html.rkt")
- (define-runtime-path snippets-html.rkt "snippets-html.rkt")
- (define-runtime-path dust.rkt "dust.rkt")
- (define-runtime-path crystalize.rkt "crystalize.rkt")
- (define-runtime-path cache.rkt "cache.rkt")
- (define-runtime-path series-list.rkt "series-list.rkt")
- (define cache-watchlist
- (map resolve-module-path
- (list tags-html.rkt
- snippets-html.rkt
- dust.rkt
- cache.rkt
- series-list.rkt
- crystalize.rkt))))
-
-;; Macro for defining tag functions that automatically branch based on the
-;; current output format and the list of poly-targets in the setup module.
-;; Use this macro when you know you will need keyword arguments.
-;;
-(define-syntax (poly-branch-kwargs-tag stx)
- (syntax-parse stx
- [(_ TAG:id)
- (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
- (for/list ([target (in-list targets)])
- (list target (format-id stx "~a-~a" target #'TAG)))]
- [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
- #'(define-tag-function (TAG attributes elems)
- (case (current-poly-target)
- [(POLY-TARGET) (POLY-FUNC attributes elems)] ...
- [else (DEFAULT-FUNC attributes elems)])))]))
-
-;; Like above, but uses `define` instead of `define-tag-function`.
-;; Use this when you know you will not need keyword arguments.
-;;
-(define-syntax (poly-branch-tag stx)
- (syntax-parse stx
- [(_ TAG:id)
- (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
- (for/list ([target (in-list targets)])
- (list target (format-id stx "~a-~a" target #'TAG)))]
- [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
- #'(define (TAG . args)
- (case (current-poly-target)
- [(POLY-TARGET) (apply POLY-FUNC args)] ...
- [else (apply DEFAULT-FUNC args)])))]))
-
-;; Define all the tag functions
-(poly-branch-tag root)
-(poly-branch-tag title)
-(poly-branch-tag excerpt)
-(poly-branch-tag excerpt*)
-
-(poly-branch-tag p)
-(poly-branch-tag i)
-(poly-branch-tag em)
-(poly-branch-tag b)
-(poly-branch-tag mono)
-(poly-branch-tag strong)
-(poly-branch-tag strike)
-;(poly-branch-tag color)
-(poly-branch-tag ol)
-(poly-branch-tag ul)
-(poly-branch-tag item)
-(define li item) ; useful alias :-P
-(poly-branch-tag sup)
-(poly-branch-tag blockquote)
-(poly-branch-tag newthought)
-(poly-branch-tag sep)
-(poly-branch-tag caps)
-(poly-branch-tag center)
-(poly-branch-tag section)
-(poly-branch-tag subsection)
-(poly-branch-tag code)
-(poly-branch-tag dialogue)
-(poly-branch-tag say)
-(poly-branch-tag saylines)
-(poly-branch-tag magick) ; Extra-fancy ligatures, “long s”
-(poly-branch-kwargs-tag index)
-(poly-branch-tag figure)
-(poly-branch-tag figure-@2x)
-(poly-branch-tag image-link)
-(poly-branch-kwargs-tag blockcode)
-(poly-branch-kwargs-tag verse) ; [#:title ""] [#:italic "no"]
-(poly-branch-tag attrib)
-
-(poly-branch-tag link)
-(poly-branch-tag url)
-(poly-branch-tag xref)
-(poly-branch-tag fn)
-(poly-branch-tag fndef)
-
-(poly-branch-kwargs-tag note-with-srcline)
-(poly-branch-tag block)
-
-;; Not yet implemented
-; (poly-branch-tag table) ; #:columns ""
-; (poly-branch-tag inline-math)
-; (poly-branch-tag margin-note)
-; (poly-branch-tag noun)
-; (poly-branch-func index-entry entry)
-; (poly-branch-tag spot-illustration) ; #:src "img--sans-path.png" [#:has-print-version? "yes"]
-
-(define-syntax (note stx)
- (syntax-parse stx
- [(_ args ...)
- (with-syntax ([srcline (number->string (syntax-line stx))])
- #'(note-with-srcline #:srcline srcline args ...))]))
-
-;; My pet shortcut for for/splice. Greatly cuts down on parentheses for the
-;; most common use case (looping through a single list).
-(define-syntax (for/s stx)
- (syntax-case stx ()
- [(_ thing listofthings result-expr ...)
- #'(for/splice ([thing (in-list listofthings)]) result-expr ...)]))
+(require pollen/decode
+ txexpr
+ yarn/markup
+ yarn/string
+ yarn/tools)
+
+(provide
+ (all-defined-out)
+ (all-from-out yarn/markup))
+
+(module+ setup
+ (provide block-tags)
+ (define block-tags blocks-elements))
+
+;; 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 'paragraph #:linebreak-proc no-linebreaks))
+
+(define (root . elems)
+ (validate-txexpr `(test ,@elems))
+ (check-title elems)
+ `(document ,@(decode-hardwrapped-paragraphs elems)))
+
+(define (check-title elems)
+ (cond
+ [(and (not (meta-set? 'title))
+ ((tx-is? 'poetry #:has-attrs 'title) (car elems)))
+ (set-meta 'title (format "‘~a’" (attr-ref (car elems) 'title)))
+ (set-meta 'title-supplied? #t)]
+ [(not (meta-set? 'title))
+ (set-meta 'title (first-words elems 5))]))
Index: yarn-lib/markup.rkt
==================================================================
--- yarn-lib/markup.rkt
+++ yarn-lib/markup.rkt
@@ -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
+
ADDED yarn-lib/render/html.rkt
Index: yarn-lib/render/html.rkt
==================================================================
--- yarn-lib/render/html.rkt
+++ yarn-lib/render/html.rkt
@@ -0,0 +1,162 @@
+#lang racket/base
+
+; SPDX-License-Identifier: BlueOak-1.0.0
+; This file is licensed under the Blue Oak Model License 1.0.0.
+
+;; Renders a Yarn AST and metadata into HTML
+
+(require "../tools.rkt"
+ "../string.rkt"
+ koyo/haml
+ pollen/core
+ pollen/decode
+ racket/function
+ racket/list
+ racket/match
+ racket/string
+ txexpr)
+
+(provide doc->html)
+
+;; TODO: most of this should all go into the template code
+(define (doc->html doc)
+ (define-values (title-type class)
+ (if (meta-set? 'title-supplied?)
+ (values 'given "with-title")
+ (values 'generated "no-title")))
+ (haml
+ (:article.h-entry
+ [[:class class]]
+ ,@(heading/permlink title-type)
+ (:section.entry-content
+ ,@(decode-elements #:block-txexpr-proc render-block
+ #:inline-txexpr-proc render-inline
+ (cdr doc))))))
+
+;; TODO: This should really go into the template code
+(define (heading/permlink title-type)
+ (define m (current-metas))
+ (define p (hash-ref m 'published))
+ (case title-type
+ [(given)
+ (haml
+ (:h1.entry-title ,@(hash-ref m 'title))
+ (:p.time
+ (:a.rel-bookmark
+ [[:href (string-append "/" (here-output-path))]]
+ (:time.published [[:datetime p]] (ymd->english p)))))]
+ [(generated)
+ (haml
+ (:h1
+ (:a.rel-bookmark
+ [[:href (string-append "/" (here-output-path))]]
+ (:time.entry-title [[:datetime p]] (ymd->english p)))))]))
+
+;; 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)
+
+(define (render-block e)
+ (match e
+ [(list 'heading (list (list 'level lev)) elems ...) (render-heading lev elems)]
+ [(list 'paragraph elems ...) `(p ,@elems)]
+ [(list 'thematic-break style) `(hr [[class ,style]])]
+ [(list 'blockquote elems ...) `(blockquote ,@elems)]
+ [(txexpr 'poetry attrs elems) (render-poetry attrs elems)]
+ [(txexpr 'codeblock attrs elems) (render-codeblock attrs elems)]
+ [(txexpr 'itemization attrs elems) (render-itemization attrs elems)]
+ [(txexpr 'dialogue _ elems) `(dl ,@elems)]
+ [(list 'speech interlocutor elems ...)
+ `(@ (dt ,interlocutor (span [[class "x"]] ": ")) (dd ,@elems))]
+ [(txexpr 'figure attrs elems) (render-figure (car elems) (cdr elems))]
+ [else (raise-argument-error 'render-block "block-content" e)]))
+
+;; 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 (render-inline e)
+ (match e
+ [(list 'italic elems ...) `(i ,@elems)]
+ [(list 'bold elems ...) `(b ,@elems)]
+ [(list 'monospace elems ...) `(samp ,@elems)]
+ [(list 'strikethrough elems ...) `(del ,@elems)]
+ [(list 'caps elems ...) `(span [[class "caps"]] ,@elems)]
+ [(list 'link dest elems ...) (render-link dest elems)]
+ [(list 'xref type key elems ...) (render-xref type key elems)]
+ [(list 'footnote-ref ref) (render-footnote-ref ref)]
+ [(list 'item elems ...) `(li ,@elems)]
+ [else e]))
+
+(define (render-link dest elems)
+ (define url
+ (or (get-metas-subhash 'urls dest)
+ (format "#Missing_Reference_~a" dest)))
+ `(a [[href ,url]] ,@elems))
+
+(define (render-heading level elems)
+ (define tag (string->symbol (format "h~a" level)))
+ `(,tag ,@elems))
+
+(define (render-poetry attrs elems)
+ (define title
+ (match (attr-ref attrs 'title attrs #f)
+ [(? string? t) `(p [[class "verse-heading"]] ,t)]
+ [_ ""]))
+ (define pre-attrs
+ (cond
+ [(string-contains? (attr-ref attrs 'style "") "italic")
+ '((style "font-style: italic"))]
+ [else '()]))
+ `(div [[class "poem"]] ,title (pre [[class "verse"] ,@pre-attrs] ,@elems)))
+
+(define (render-codeblock attrs elems)
+ (define file (or (assoc 'filename attrs) ""))
+ (define codeblock `(pre [[class "code"]] (code ,@elems)))
+ (cond [(non-empty-string? file) `(@ (div [[class "listing-filename"]] 128196 " " ,file) ,codeblock)]
+ [else codeblock]))
+
+(define (render-itemization attrs elems)
+ (define tag (if (attr-ref attrs 'start #f) 'ol 'ul))
+ `(,tag ,attrs ,@elems))
+
+(define (render-figure source elems)
+ `(figure [[class "fullwidth"]]
+ (img [[src ,source]] [[alt ,(->text elems)]])
+ (figcaption ,@elems)))
+
+;; The AST guarantees that they key will already be URI-safe
+(define (render-xref type key elems)
+ `(a [[id ,(here-key (format "_~a-~a" type key))]
+ [href ,(string-append "/keyword-index.html#" key)] ; TODO: ref type links need to resolve to the target
+ [data-index-entry ,key]
+ [class ,(symbol->string type)]]
+ ,@elems))
+
+(define (render-footnote-ref ref)
+ (cons-to-metas-list 'fn-names ref)
+ (let* ([here (here-key)]
+ [fn-names (hash-ref (current-metas) 'fn-names)]
+ [def-anchor (format "#~a_fndef_~a" here ref)]
+ [nth-ref (number->string (count (curry equal? ref) fn-names))]
+ [ref-id (format "#~a_fn_~a_~a" here ref nth-ref)]
+ [fn-number (+ 1 (index-of (remove-duplicates (reverse fn-names)) ref))]
+ [ref-text (format "(~a)" fn-number)])
+ `(sup (a [[href ,def-anchor] [id ,ref-id]] ,ref-text))))
ADDED yarn-lib/string.rkt
Index: yarn-lib/string.rkt
==================================================================
--- yarn-lib/string.rkt
+++ yarn-lib/string.rkt
@@ -0,0 +1,113 @@
+#lang racket/base
+
+(require gregor
+ racket/match
+ racket/string
+ txexpr)
+
+(provide ->text
+ first-words
+ ymd->english)
+
+(module+ test (require rackunit))
+
+;; Concatenate the string elements of a txexpr or list together
+(define (->text v)
+ (match v
+ [(txexpr _ _ elements) (->text elements)]
+ [(list elements ...) (string-append* (map ->text elements))]
+ [(? string? s) s]
+ [_ ""]))
+
+;; Return the first N words out of a list of txexprs. This function will unpack the strings out of
+;; the elements of one txexpr at a time until it finds the requested number of words. It aims to be
+;; both reliable and fast for any size of list you pass it, and smart about the punctuation it
+;; allows through.
+(define (first-words txprs words-needed)
+ (define punc-allowed-in-word '(#\- #\' #\% #\$ #\‘ #\’ #\# #\& #\/ #\. #\!))
+
+ (define (word-boundary? c) (or (char-whitespace? c) (equal? c #\null) (eof-object? c)))
+ (define (word-char? c) (or (char-alphabetic? c) (char-numeric? c)))
+
+ (define in (open-input-string (->text (car txprs))))
+ (define out (open-output-string))
+
+ (define words-found
+ (let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
+ (define c (read-char in))
+
+ (cond [(equal? words-found words-needed) words-found]
+ [(eof-object? c)
+ (cond [(positive? words-found) (if last-c-in-word? (+ 1 words-found) words-found)]
+ [else 0])]
+ [else
+ (define-values (write-this-char? new-word-count c-in-word?)
+ (cond
+ ;; Spaces increment the word count if the previous character was part of,
+ ;; or adjacent to, a word
+ [(and (char-whitespace? c) last-c-in-word?)
+ (values (if (equal? words-needed (+ 1 words-found)) #f #t) (+ 1 words-found) #f)]
+ ;; Some punctuation survives if the previous or next char is part of a word
+ [(member c punc-allowed-in-word)
+ (cond [(or (word-char? last-c) (word-char? (peek-char in)))
+ (values #t words-found #t)]
+ [else (values #f words-found #f)])]
+ [(word-char? c)
+ (values #t words-found #t)]
+ ;; If c is a non-whitespace non-allowed character that immediately follows a word,
+ ;; do not write it out but count it as being part of the word.
+ [(and (not (word-char? c)) (not (char-whitespace? c)) last-c-in-word?)
+ (values #f words-found #t)]
+ [else (values #f words-found #f)]))
+
+ (cond [(and (char-whitespace? c) write-this-char?) (write-char #\space out)]
+ [write-this-char? (write-char c out)])
+ (loop new-word-count c c-in-word?)])))
+
+ (define words (get-output-string out))
+ (cond [(equal? words-found words-needed) (string-append words "…")]
+ [(equal? '() (cdr txprs)) words]
+ [else (string-append words " " (first-words (cdr txprs) (- words-needed words-found)))]))
+
+(module+ test
+ (require rackunit)
+ (define txs-decimals
+ '((p "Four score and 7.8 years ago — our fathers brought forth on this continent etc etc")))
+ (define txs-punc+split-elems
+ '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
+ (define txs-dashes
+ '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
+ (p "That was all she would allow.")))
+ (define txs-parens-commas
+ '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
+ (define txs-short
+ '((span "Not much here!")))
+
+ (check-equal? (first-words txs-decimals 5) "Four score and 7.8 years…")
+ (check-equal? (first-words txs-punc+split-elems 5) "Stop! she called. She was…")
+ (check-equal? (first-words txs-dashes 5) "One and only one. That…")
+ (check-equal? (first-words txs-dashes 4) "One and only one.…")
+ (check-equal? (first-words txs-parens-commas 5) "She counted one two silently…")
+ (check-equal? (first-words txs-short 5) "Not much here!"))
+
+;; ~~~ Convenience functions for YYYY-MM-DD date strings ~~~
+
+;; These functions ignore everything after the first space in the input!
+(define (ymd->dateformat ymd-string dateformat)
+ (~t (iso8601->date (car (string-split ymd-string))) dateformat))
+
+(define (ymd->english ymd-string)
+ (ymd->dateformat ymd-string "MMMM d, yyyy"))
+
+(module+ test
+ (check-equal? (ymd->english "2018-08-12") "August 12, 2018")
+ (check-equal? (ymd->dateformat "2018-08-12" "d MMM YYYY") "12 Aug 2018")
+
+ ;; How we handle weird input
+ (check-equal? (ymd->english "2018-08-12 everything after 1st space ignored") "August 12, 2018")
+ (check-equal? (ymd->english "2018-08 omitting the day") "August 1, 2018")
+ (check-equal? (ymd->english "2018 omitting month and day") "January 1, 2018")
+ (check-equal? (ymd->dateformat "2018-08-12" "123") "123")
+
+ ;; Stuff we just don't handle
+ (check-exn exn:gregor:parse? (lambda () (ymd->english "2018-xyz"))))
ADDED yarn-lib/tools.rkt
Index: yarn-lib/tools.rkt
==================================================================
--- yarn-lib/tools.rkt
+++ yarn-lib/tools.rkt
@@ -0,0 +1,78 @@
+#lang racket/base
+
+(require file/sha1
+ pollen/core
+ pollen/file
+ pollen/setup
+ (only-in racket/function identity)
+ racket/match
+ racket/path
+ racket/string
+ threading
+ txexpr)
+
+(provide (all-defined-out))
+
+;; Convert a string into all lowercase, delete all non-alphanum chars, replace spaces with ‘-’
+(define (normalize-key str)
+ (~> (string-downcase str)
+ (regexp-replace #rx"ies$" _ "y")
+ (string-trim "s" #:left? #f)
+ (regexp-replace* #rx"[^A-Za-z0-9 ]" _ "")
+ (string-normalize-spaces #px"\\s+" "-")))
+
+;; ~~ Metas reference and updating ~~~~~~~~~~~~~~~
+
+;; Computes a unique string key for the current Pollen source and stashes it in the metas
+(define (here-key [suffix ""])
+ (define metas (current-metas))
+ (define (set-here-key!)
+ (set-meta 'here-key
+ (~> (hash-ref metas 'here-path)
+ string->bytes/utf-8
+ sha1-bytes
+ bytes->hex-string
+ (substring 0 8))))
+ (string-append (hash-ref metas 'here-key set-here-key!) suffix))
+
+(define (here-source-path #:string? [string? #t])
+ (define proc (if string? path->string identity))
+ (cond
+ [(current-metas)
+ (proc (find-relative-path (current-project-root) (hash-ref (current-metas) 'here-path)))]
+ [else "."]))
+
+(define (here-output-path #:string? [string? #t])
+ (define proc (if string? path->string identity))
+ (proc (->output-path (here-source-path #:string? #f))))
+
+(define (meta-set? key)
+ (and (hash-ref (current-metas) key #f) #t))
+
+(define (set-meta key val)
+ (current-metas (hash-set (current-metas) key val))
+ val)
+
+(define (cons-to-metas-list key val)
+ (define consed (cons val (hash-ref (current-metas) key '())))
+ (current-metas (hash-set (current-metas) key consed))
+ consed)
+
+(define (update-metas-subhash key subkey val [proc (λ (v) v)])
+ (define metas (current-metas))
+ (define subhash (hash-ref metas key hasheq))
+ (set-meta key (hash-set subhash subkey (proc val))))
+
+(define (get-metas-subhash key subkey)
+ (hash-ref (hash-ref (current-metas) key #hasheq()) subkey #f))
+
+;; Returns a function will test if a txexpr's tag matches the given symbol and
+;; (optionally) contains all given attributes.
+(define (tx-is? t #:has-attrs [a '()])
+ (define tags (if (list? t) tags (list t)))
+ (define attrs (if (list? a) a (list a)))
+ (lambda (v)
+ (and (txexpr? v)
+ (member (get-tag v) tags)
+ (andmap (λ (attr) (attrs-have-key? a attr)) attrs)
+ #t)))