Eliminate special renderer support for footnotes

This commit reimplements footnotes “properly,” as Scribble references,
rather than handling them separately in `footnotes-render-mixin`.

Author: lexi-lambda

blog/build/render/scribble.rkt

@@ -23,6 +23,7 @@
          threading
          (only-in xml write-xexpr xexpr/c)
 
+         "../../lang/metadata.rkt"
          "../../lang/post-language.rkt"
          "../../paths.rkt"
          "../metadata.rkt"
@@ -37,7 +38,6 @@
                (implementation?/c render<%>))])
 
          blog-render-mixin
-         footnotes-render-mixin
          pygments-render-mixin)
 
 ;; -----------------------------------------------------------------------------
@@ -59,7 +59,7 @@
   (for/list ([(k v) (in-hash attrs)])
     (list k v)))
 
-(define (style->tag-name+attributes s)
+(define (style->tag-name+attributes s ri)
   (for/fold ([tag-name #f]
              [attrs (if (string? (style-name s))
                         (hasheq 'class (style-name s))
@@ -72,6 +72,9 @@
        (values (string->symbol name) attrs)]
       [(attributes attrs*)
        (values tag-name (attributes-union attrs (make-immutable-hasheq attrs*)))]
+      [(link-target tag)
+       (values tag-name (attributes-union attrs
+                                          (hasheq 'id (tag->anchor-name (resolve-tag tag ri)))))]
       [_
        (values tag-name attrs)])))
 
@@ -89,7 +92,7 @@
 (serializable-struct blog-page (title path) #:transparent
   #:guard (struct-guard/c content? site-path?))
 (serializable-struct blog-page-anchor (title path anchor) #:transparent
-  #:guard (struct-guard/c content? site-path? string?))
+  #:guard (struct-guard/c (or/c content? #f) site-path? string?))
 
 (define header-depth->html-tag
   (match-lambda
@@ -217,14 +220,29 @@
                                             (get-current-site-path)
                                             (tag->anchor-name (add-current-tag-prefix key)))))))
 
+    (define/public (collect-link-target tag ci)
+      (define key (generate-tag tag ci))
+      (collect-put! ci key (blog-page-anchor #f
+                                             (get-current-site-path)
+                                             (tag->anchor-name (add-current-tag-prefix key)))))
+
+    (define/override (collect-nested-flow i ci)
+      (cond
+        [(findf link-target? (style-properties (nested-flow-style i)))
+         => (λ (target) (collect-link-target (link-target-tag target) ci))])
+      (super collect-nested-flow i ci))
+
+    (define/override (collect-paragraph i ci)
+      (cond
+        [(findf link-target? (style-properties (paragraph-style i)))
+         => (λ (target) (collect-link-target (link-target-tag target) ci))])
+      (super collect-paragraph i ci))
+
     (define/override (collect-target-element i ci)
-      (define key (generate-tag (target-element-tag i) ci))
       (when (redirect-target-element? i)
         (raise-arguments-error 'collect-target-element "redirect targets not supported"
                                "element" i))
-      (collect-put! ci key (blog-page-anchor #f
-                                             (get-current-site-path)
-                                             (tag->anchor-name (add-current-tag-prefix key)))))
+      (collect-link-target (target-element-tag i) ci))
 
     (define/override (resolve-content i d ri)
       (cond
@@ -274,17 +292,20 @@
         ,@(append-map (λ~> (render-part ri)) (part-parts part))])
 
     (define/override (render-nested-flow i part ri starting-item?)
-      `[(blockquote ,@(super render-nested-flow i part ri starting-item?))])
+      (define-values [tag-name attrs] (style->tag-name+attributes (nested-flow-style i) ri))
+      `[(,(or tag-name 'blockquote)
+         ,(attributes->list attrs)
+         ,@(super render-nested-flow i part ri starting-item?))])
 
     (define/override (render-paragraph e part ri)
-      (define-values [tag-name attrs] (style->tag-name+attributes (paragraph-style e)))
+      (define-values [tag-name attrs] (style->tag-name+attributes (paragraph-style e) ri))
       `[(,(or tag-name 'p)
          ,(attributes->list attrs)
          ,@(super render-paragraph e part ri))])
 
     (define/override (render-itemization e part ri)
       (define style (itemization-style e))
-      (define-values [tag-name attrs] (style->tag-name+attributes style))
+      (define-values [tag-name attrs] (style->tag-name+attributes style ri))
       `[(,(or tag-name
               (if (eq? (style-name style) 'ordered) 'ol 'ul))
          ,(attributes->list attrs)
@@ -305,7 +326,7 @@
         [(string? elem) (list elem)]
         [else
          (define style (normalize-element-style (if (element? elem) (element-style elem) #f)))
-         (define-values [tag-name attrs] (style->tag-name+attributes style))
+         (define-values [tag-name attrs] (style->tag-name+attributes style ri))
 
          (define (wrap-for-style rendered #:attrs [attrs attrs])
            ; First, we determine what element wrappers are needed by the style.
@@ -361,9 +382,6 @@
            [(link-element _ _ tag)
             (define indirect? (memq 'indirect-link (style-properties style)))
             (define dest (and (not indirect?) (resolve-get part ri tag)))
-            (unless (or dest indirect?)
-              (error 'render "unknown link destination\n  tag: ~e" tag))
-
             (define href
               (match dest
                 ; racket doc reference
@@ -388,76 +406,6 @@
 
     (super-new)))
 
-;; Adds support for footnote definitions and references to a renderer.
-;; Specifically, the renderer is adjusted as follows:
-;;
-;;   * An `element` with a `footnote-reference` style property is treated as a
-;;     /footnote references/. The content of footnote references is ignored, and
-;;     the element is replaced with a link to the corresponding footnote
-;;     definition.
-;;
-;;  * A `nested-flow` with a `footnote-definition` style property is treated as
-;;    a /footnote definition/. During the render pass, footnote definitions are
-;;    removed from the document flow in `render-flow` and rendered separately.
-;;    The collected footnote definitions can be retrieved using the
-;;    `get-rendered-footnote-definitions` method in a subclassing renderer.
-;;
-;;  * The `render-footnote-definition` method can be overridden to customize the
-;;    way footnote definitions are rendered.
-(define (footnotes-render-mixin %)
-  (class/hijack %
-    #:hijack-methods [render-one]
-
-    (define footnote-ids '())
-    (define footnote-definitions '())
-
-    (define/override (start-collect ds fns ci)
-      (set! footnote-ids '())
-      (super start-collect ds fns ci))
-
-    (define/override (collect-nested-flow b ci)
-      (cond
-        [(findf footnote-definition? (style-properties (nested-flow-style b)))
-         => (λ (defn) (set! footnote-ids (cons (footnote-definition-note-id defn) footnote-ids)))])
-      (super collect-nested-flow b ci))
-
-    (define/public (get-rendered-footnote-definitions)
-      (reverse footnote-definitions))
-
-    (define/public-final (super-render-one part ri output-file)
-      (super render-one part ri output-file))
-    (define/overment (render-one part ri output-file)
-      (set! footnote-ids (reverse footnote-ids))
-      (set! footnote-definitions '())
-      (inner/hijack render-one part ri output-file))
-
-    (define/override (render-content elem part ri)
-      (match elem
-        [(element (style #f (list (footnote-reference note-id))) '())
-         (define note-index (and~> (index-of footnote-ids note-id) add1))
-         `[(sup (a ([href ,(if note-index
-                               (~a "#footnote-" note-index)
-                               "#")])
-                   ,(or (~a note-index) "???")))]]
-        [_ (super render-content elem part ri)]))
-
-    (define/override (render-flow blocks part ri starting-item?)
-      (define-values [footnote-blocks other-blocks]
-        (partition (λ (block) (and (nested-flow? block)
-                                   (~>> (nested-flow-style block)
-                                        style-properties
-                                        (memf footnote-definition?))))
-                   blocks))
-      (for ([footnote-block (in-list footnote-blocks)])
-        (define rendered (render-footnote-definition footnote-block part ri))
-        (set! footnote-definitions (cons rendered footnote-definitions)))
-      (super render-flow other-blocks part ri starting-item?))
-
-    (define/public (render-footnote-definition block part ri)
-      (render-flow (nested-flow-blocks block) part ri #t))
-
-    (super-new)))
-
 ;; Recognizes `paragraph`s and `element`s with a `pygments-content` style
 ;; property and replaces them with the result of running Pygments on the content
 ;; in the property. Body content and other style properties are ignored.
@@ -501,11 +449,10 @@
 
 ;; The renderer used for actual blog posts, with all the bells and whistles.
 (define blog-post-render%
-  (class (pygments-render-mixin (footnotes-render-mixin (blog-render-mixin base-render%)))
+  (class (pygments-render-mixin (blog-render-mixin base-render%))
     (inherit render-content
              render-flow
-             render-part
-             get-rendered-footnote-definitions)
+             render-part)
 
     ; We don’t render blog posts directly to HTML because we need to be able to
     ; render them in different ways on different pages, so we generate `.info`
@@ -521,19 +468,14 @@
       (define props (style-properties (part-style part)))
       (define title-str (content->string (strip-aux (part-title-content part)) this part ri))
       (define title-content (render-content (part-title-content part) part ri))
-      (define body-main-content (append (render-flow (part-blocks part) part ri #t)
+      (define body-content (append (render-flow (part-blocks part) part ri #t)
                                         (append-map (λ~> (render-part ri)) (part-parts part))))
-      (define footnotes-block
-        `(div ([class "footnotes"])
-           (ol ,@(for/list ([footnote-element (in-list (get-rendered-footnote-definitions))]
-                            [footnote-index (in-naturals 1)])
-                   `(li ([id ,(~a "footnote-" footnote-index)]) ,@footnote-element)))))
       (define post
         (rendered-post title-str
                        title-content
                        (get-required-style-prop post-date? props)
                        (post-tags-tags (get-required-style-prop post-tags? props))
-                       (append body-main-content (list footnotes-block))))
+                       body-content))
       (write (serialize post))
       post)
 

blog/build/render/util.rkt

@@ -42,9 +42,10 @@
 (define tag->anchor-name
   (match-lambda
     [(literal-anchor anchor-name) anchor-name]
-    [(cons 'part tag) (tag->anchor-name tag)]
-    [(? list? elements)
+    [(list 'part tag) (to-slug (~a tag))]
+    [(list sym (cons 'prefixable tag)) (tag->anchor-name (list sym tag))]
+    [(list sym tag)
      ; This anchor naming scheme does not in any way create unique anchors, but
      ; that should be okay for internal references in this use case, and having
      ; pretty URLs is a nice feature.
-     (to-slug (string-join (map ~a elements) " "))]))
+     (to-slug (~a sym tag))]))

blog/lang/footnote.rkt

@@ -0,0 +1,122 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     racket/syntax)
+         racket/contract
+         racket/format
+         racket/list
+         racket/match
+         scribble/core
+         scribble/decode
+         scribble/html-properties
+         syntax/parse/define
+         threading
+
+         "metadata.rkt")
+
+(provide define-footnote
+         (contract-out
+          [make-footnote-tag (->* [string?]
+                                  [#:post (or/c string? #f)
+                                   #:tag-prefixes (listof string?)]
+                                  tag?)]
+          [footnote-ref (-> string? content?)]
+          [footnote-decl (-> string? pre-flow? ... part-collect-decl?)]
+          [footnotes-section (-> part?)]))
+
+(define (make-footnote-tag tag-str
+                           #:post [post-path #f]
+                           #:tag-prefixes [tag-prefixes '()])
+  `(footnote ,(taglet-add-prefix (cons 'prefixable
+                                       (if post-path
+                                           (cons post-path tag-prefixes)
+                                           tag-prefixes))
+                                 tag-str)))
+
+(define footnote-refs-key (gensym 'footnote-refs))
+(define footnote-flows-key (gensym 'footnote-flows))
+
+(define (footnote-ref tag)
+  (traverse-element
+   (λ (get set)
+     (define refs (get footnote-refs-key '()))
+     (define number (cond
+                      [(index-of refs tag)
+                       => (λ (idx) (- (length refs) idx))]
+                      [else
+                       (set footnote-refs-key (cons tag refs))
+                       (add1 (length refs))]))
+     (link-element (style 'superscript '())
+                   (~a number)
+                   (make-footnote-tag tag)))))
+
+(define (footnote-decl tag . pre-flows)
+  (part-collect-decl
+   (element
+    #f
+    (traverse-element
+     (λ (get set)
+       (set footnote-flows-key
+            (cons (cons tag (decode-flow pre-flows))
+                  (get footnote-flows-key '())))
+       '())))))
+
+(define (footnotes-section)
+  (define (generate get set)
+    (define refs (get footnote-refs-key '()))
+    (define-values [referenced-flows other-flows]
+      (partition (λ~> car (member refs)) (get footnote-flows-key '())))
+
+    (define (build-item number tag+blocks)
+      (nested-flow
+       (style #f (list* (alt-tag "li")
+                        (link-target (make-footnote-tag (car tag+blocks)))
+                        (if number
+                            (list (attributes `([value . ,(~a number)])))
+                            '())))
+       (cdr tag+blocks)))
+
+    ; Build the footnote items, starting with the ones that were actually
+    ; referenced. If a footnote was referenced that doesn’t actually exist, we
+    ; want to skip its number in the output list, which requires we set the
+    ; `value` attribute on the generated `li`. The `skipped?` argument tracks
+    ; whether or not this is necessary for the next `li`.
+    (define items
+      (let loop ([refs (reverse refs)]
+                 [number 1]
+                 [skipped? #f])
+        (match refs
+          [(cons ref refs)
+           (match (assoc ref referenced-flows)
+             [(? pair? flow)
+              (cons (build-item (and skipped? number) flow)
+                    (loop refs (add1 number) #f))]
+             [#f (loop refs (add1 number) #t)])]
+
+          ; We’re done outputting the referenced footnotes. If there were any
+          ; unreferenced ones, just tack them onto the end.
+          ['() (match other-flows
+                 ['() '()]
+                 [(cons flow flows)
+                  (cons (build-item (and skipped? number) flow)
+                        (map (λ~>> (build-item #f)) flows))])])))
+
+    (nested-flow (style #f (list (alt-tag "ol")
+                                 (attributes '([class . "footnotes"]))))
+                 items))
+  (part #f
+        (list `(part ,(generated-tag)))
+        #f
+        (style #f '(unnumbered hidden toc-hidden))
+        '()
+        (list (traverse-block generate))
+        '()))
+
+(define-syntax-parser define-footnote
+  [(_ ref-id:id {~optional {~seq #:tag tag-e}} pre-flow ...)
+   #:declare tag-e (expr/c #'string? #:name "tag")
+   #:with note-ref-id (format-id #'ref-id "note:~a" #'ref-id #:subs? #t)
+   #`(begin
+       (define note-tag {~? tag-e.c '#,(symbol->string (syntax-e #'ref-id))})
+       (define (note-ref-id) (footnote-ref note-tag))
+       (footnote-decl note-tag pre-flow ...))])