Add support for an external-title style property

Author: lexi-lambda

blog/build/render/scribble.rkt

@@ -133,6 +133,18 @@
 (define (resolve-tag base-tag ri)
   (add-current-tag-prefix (tag-key base-tag ri)))
 
+;; Taken from `scribble/base-render` to match what the base renderer does.
+(define (extend-tag-prefix d fresh?)
+  (cond
+    [fresh? null]
+    [(part-tag-prefix d)
+     (cons (part-tag-prefix d) (current-tag-prefixes))]
+    [else (current-tag-prefixes)]))
+
+(define (part-render-style d)
+  (or (findf link-render-style? (style-properties (part-style d)))
+      (current-link-render-style)))
+
 (define tag->local-redirect-query-string
   (let ()
     (define racket-renderer (new (scribble:render-mixin render%)
@@ -195,10 +207,25 @@
 ;;   * `render-nested-flow` calls `render-flow` instead of calling `render-block`
 ;;     directly. As a side-effect of this change, `render-nested-flow` returns a
 ;;     flat list (of rendered blocks) rather than a list of lists.
+;;
+;; Additionally, `base-render%` handles appropriately traversing, collecting,
+;; and resolving content in any `external-title` style properties on parts,
+;; though it does not use the content for anything.
 (define base-render%
   (class/hijack render%
     #:hijack-methods [render-one]
-    (inherit collect-part render-flow)
+    (inherit traverse-content
+             collect-content collect-part
+             fresh-tag-resolve-context? resolve-content resolve-flow
+             render-flow)
+
+    (define/override (traverse-part d fp)
+      (~>> (cond
+             [(findf external-title? (style-properties (part-style d)))
+              => (λ (ext-title)
+                   (traverse-content (external-title-content ext-title) fp))]
+             [else fp])
+           (super traverse-part d)))
 
     (define/override (start-collect ds fns ci)
       (for-each (lambda (d fn)
@@ -208,6 +235,31 @@
                 ds
                 fns))
 
+    (define/override (collect-part-tags d ci number)
+      (super collect-part-tags d ci number)
+      (cond
+        [(findf external-title? (style-properties (part-style d)))
+         => (λ (ext-title)
+              (collect-content (external-title-content ext-title) ci))]))
+
+    ; We unfortunately have to replace this method wholesale, since we need to
+    ; resolve the title content with `current-tag-prefixes` and
+    ; `current-link-render-style` properly adjusted. The implementation is
+    ; otherwise taken from `scribble/base-render` unmodified.
+    (define/override (resolve-part d ri)
+      (parameterize ([current-tag-prefixes
+                      (extend-tag-prefix d (fresh-tag-resolve-context? d ri))]
+                     [current-link-render-style (part-render-style d)])
+        (when (part-title-content d)
+          (resolve-content (part-title-content d) d ri))
+        (cond
+          [(findf external-title? (style-properties (part-style d)))
+           => (λ (ext-title)
+                (resolve-content (external-title-content ext-title) d ri))])
+        (resolve-flow (part-blocks d) d ri)
+        (for ([p (part-parts d)])
+          (resolve-part p ri))))
+
     (define/overment (render-one part ri output-file)
       (parameterize ([current-output-file output-file]
                      [current-top-part part])
@@ -264,11 +316,18 @@
     (define/override (collect-part-tags d ci number)
       (for ([t (part-tags d)])
         (define key (generate-tag t ci))
-        (define title (or (part-title-content d) "???"))
+        (define title-content
+          (cond
+            [(findf external-title? (style-properties (part-style d)))
+             => (λ (ext-title)
+                  (collect-content (external-title-content ext-title) ci)
+                  (external-title-content ext-title))]
+            [(part-title-content d)]
+            [else "???"]))
         (collect-put! ci key
                       (if (current-part-whole-page? d)
-                          (blog-page title (get-current-site-path))
-                          (blog-page-anchor title
+                          (blog-page title-content (get-current-site-path))
+                          (blog-page-anchor title-content
                                             (get-current-site-path)
                                             (tag->anchor-name (add-current-tag-prefix key)))))))
 

blog/lang/base.rkt

@@ -23,6 +23,7 @@
          (struct-out post-date)
          (struct-out post-tags)
          (struct-out table-rows)
+         (struct-out external-title)
          blog-post
          deftech
          tech

blog/lang/metadata.rkt

@@ -17,6 +17,7 @@
           (struct link-target ([tag tag?]))
           (struct css-styles ([assoc (listof (cons/c symbol? string?))]))
           (struct table-rows ([styles (listof style?)]))
+          (struct external-title ([content content?]))
 
           [taglet-add-prefix (-> (or/c (or/c string? symbol?)
                                        (listof (or/c string? symbol?)))
@@ -49,6 +50,11 @@
 ;; apply to the table’s <tr> elements.
 (struct table-rows (styles) #:transparent)
 
+;; A style property that can be attached to a `part` to supply alternate
+;; `content` to use when the part is linked to instead of the part’s usual
+;; title content.
+(struct external-title (content) #:transparent)
+
 (define (taglet-add-prefix prefix taglet)
   (if (list? prefix)
       (foldr taglet-add-prefix taglet prefix)

blog/markdown.rkt

@@ -32,6 +32,10 @@
 
 (define (parse-title-info in)
   (match-define (list _ title-bytes) (regexp-match #px"^    Title: ([^\n]+)\n" in))
+  (define external-title-str
+    (match (regexp-try-match #px"^    External title: ([^\n]+)\n" in)
+      [(list _ external-title-bytes) (bytes->string/utf-8 external-title-bytes)]
+      [_                             #f]))
   (match-define (list _ year-bytes month-bytes day-bytes)
     (regexp-match #px"^    Date: ([0-9]{4})-([0-9]{2})-([0-9]{2})[^\n]*\n" in))
   (match-define (list _ tags-bytes)
@@ -41,10 +45,13 @@
     (string->document (bytes->string/utf-8 title-bytes)))
   (define tags (string-split (bytes->string/utf-8 tags-bytes) ", " #:trim? #f))
 
-  (title #:style (style #f (list (post-date (bytes->number year-bytes)
-                                            (bytes->number month-bytes)
-                                            (bytes->number day-bytes))
-                                 (post-tags tags)))
+  (define base-props (list (post-date (bytes->number year-bytes)
+                                      (bytes->number month-bytes)
+                                      (bytes->number day-bytes))
+                           (post-tags tags)))
+  (title #:style (style #f (if external-title-str
+                               (cons (external-title external-title-str) base-props)
+                               base-props))
          (render-inline title-content)))
 
 (define (bytes->number bs)