Add support for section and inter-post links

lexi-lambda · lexi-lambda · commit ef857960d70f · 2021-07-17T19:54:43.000-05:00
diff --git a/blog/build.rkt b/blog/build.rkt
@@ -10,17 +10,19 @@
          racket/promise
          racket/sequence
          racket/serialize
+         scribble/core
          scribble/xref
          setup/xref
          threading
          (only-in xml write-xexpr)
 
-         "markdown/post.rkt"
-         "paths.rkt"
          "build/metadata.rkt"
          "build/render/scribble.rkt"
          "build/render/feed.rkt"
-         "build/render/page.rkt")
+         "build/render/page.rkt"
+         "lang/metadata.rkt"
+         "markdown/post.rkt"
+         "paths.rkt")
 
 (define num-posts-per-page 10)
 
@@ -39,9 +41,23 @@
       (path-replace-extension #".sxref")
       (build-path build-dir _)))
 
+;; Functions like `other-doc` assume that each top-level document has the tag
+;; '(part "top") on its top-level section. This is only ensured by
+;; setup/scribble, which we are not using, so we have to add it manually.
+(define (ensure-top-tag main-part)
+  (if (member '(part "top") (part-tags main-part))
+      main-part
+      (struct-copy part main-part
+                   [tags (cons '(part "top") (part-tags main-part))])))
+
+(define (set-blog-tag-prefix main-part path-str)
+  (struct-copy part main-part [tag-prefix (blog-post-path->tag-prefix path-str)]))
+
 (define (markdown-post file-name)
   (define path (build-path posts-dir file-name))
-  (define main-part-promise (delay (parse-markdown-post (file->string path) path)))
+  (define main-part-promise (delay (~> (parse-markdown-post (file->string path) path)
+                                       ensure-top-tag
+                                       (set-blog-tag-prefix file-name))))
   (post-dep path main-part-promise))
 
 (define all-post-deps
@@ -95,16 +111,21 @@
 
 (define (render-scribble render% main-part out-path
                          #:dest-dir [dest-dir (path-only out-path)]
+                         #:xrefs-in [xref-in-paths '()]
                          #:xref-out [xref-out-path #f])
   (define main-parts (list main-part))
   (define out-paths (list out-path))
   (define renderer (new render% [dest-dir dest-dir]))
 
   (define traverse-info (send renderer traverse main-parts out-paths))
   (define collect-info (send renderer collect main-parts out-paths traverse-info))
+
+  (for ([path (in-list xref-in-paths)])
+    (define xref-in (call-with-input-file* path read))
+    (send renderer deserialize-info xref-in collect-info))
   (xref-transfer-info renderer collect-info (load-collections-xref))
-  (define resolve-info (send renderer resolve main-parts out-paths collect-info))
 
+  (define resolve-info (send renderer resolve main-parts out-paths collect-info))
   (match-define (list render-result)
     (send renderer render main-parts out-paths resolve-info))
 
@@ -172,7 +193,8 @@
   (local-require (only-in "posts/about-me.scrbl" [doc main-part]))
   (render-scribble (blog-standalone-page-render% standalone-page)
                    main-part
-                   (reroot-path site-path output-dir)))
+                   (reroot-path site-path output-dir)
+                   #:xrefs-in (map post-dep-xref-path all-post-deps)))
 
 (define (build-sitemap posts)
   (define site-path "/sitemap.txt")
diff --git a/blog/build/render/scribble.rkt b/blog/build/render/scribble.rkt
@@ -24,6 +24,7 @@
          (only-in xml write-xexpr xexpr/c)
 
          "../../lang/post-language.rkt"
+         "../../paths.rkt"
          "../metadata.rkt"
          "highlight/pygments.rkt"
          "util.rkt")
@@ -85,8 +86,10 @@
       (λ (tag) (tag->query-string tag)))))
 
 ; values associated with tags during the collect pass
-(struct blog-post (title path) #:prefab)
-(struct blog-post-anchor (title path anchor) #:prefab)
+(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?))
 
 (define header-depth->html-tag
   (match-lambda
@@ -151,7 +154,8 @@
                 fns))
 
     (define/overment (render-one part ri output-file)
-      (parameterize ([current-output-file output-file])
+      (parameterize ([current-output-file output-file]
+                     [current-top-part part])
         (inner/hijack render-one part ri output-file)))
 
     (define/override (render-nested-flow i part ri starting-item?)
@@ -175,6 +179,12 @@
     (define/override (set-external-tag-path p)
       (set! external-tag-path (string->url p)))
 
+    ;; Returns the (absolute) path portion of the URL for the page that contains
+    ;; the part currently being rendered.
+    (define/public (get-current-site-path)
+      (path->string (build-path "/" (find-relative-path (get-dest-directory)
+                                                        (current-output-file)))))
+
     ;; -------------------------------------------------------------------------
     ;; collect
 
@@ -183,8 +193,8 @@
         ; racket doc reference; index 4 corresponds to `whole-page?`
         [(? vector? dest) (vector-ref dest 4)]
         ; blog references
-        [(? blog-post?) #t]
-        [(? blog-post-anchor?) #f]))
+        [(? blog-page?) #t]
+        [(? blog-page-anchor?) #f]))
 
     (define/public (current-part-whole-page? d)
       (eq? d (current-top-part)))
@@ -199,21 +209,21 @@
     (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 (or (part-title-content d) "???"))
         (collect-put! ci key
                       (if (current-part-whole-page? d)
-                          (blog-post title (current-output-file))
-                          (blog-post-anchor title
-                                            (current-output-file)
+                          (blog-page title (get-current-site-path))
+                          (blog-page-anchor title
+                                            (get-current-site-path)
                                             (tag->anchor-name (add-current-tag-prefix key)))))))
 
     (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-post-anchor #f
-                                             (current-output-file)
+      (collect-put! ci key (blog-page-anchor #f
+                                             (get-current-site-path)
                                              (tag->anchor-name (add-current-tag-prefix key)))))
 
     (define/override (resolve-content i d ri)
@@ -248,9 +258,14 @@
 
     (define/override (render-part-content part ri)
       (define number (collected-info-number (part-collected-info part ri)))
+      (define anchors (for/list ([tag (in-list (part-tags part))])
+                        `(a ([name ,(tag->anchor-name
+                                     (add-current-tag-prefix
+                                      (tag-key tag ri)))]))))
       (define title
         (when/list (not (part-style? part 'hidden))
           `(,(header-depth->html-tag (number-depth number))
+            ,@anchors
             ,@(cond/list
                 [(part-title-content part)
                  => (λ (title-content) (render-content title-content part ri))]))))
@@ -280,8 +295,9 @@
       (define title-content
         (match (resolve-get part ri tag)
           [(vector title _ ...) title]
-          [(blog-post title _) title]
-          [(blog-post-anchor title _ _) title]))
+          [(blog-page title _) title]
+          [(blog-page-anchor title _ _) title]
+          [#f "???"]))
       (render-content title-content part ri))
 
     (define/override (render-content elem part ri)
@@ -357,18 +373,13 @@
                          (url-query external-tag-path)))
                  (url->string (struct-copy url external-tag-path [query redirect-query]))]
 
-                [(blog-post _ path)
-                 (relative-path->relative-url-string
-                  (find-relative-path (get-dest-directory) path))]
+                [(blog-page _ path)
+                 (site-path->url-string path)]
 
-                [(blog-post-anchor _ path anchor)
-                 (define file-path path)
-                 (define fragment (string-append "#" (uri-encode anchor)))
-                 (if (equal? file-path (current-output-file))
-                     fragment
-                     (string-append (relative-path->relative-url-string
-                                     (find-relative-path (get-dest-directory) file-path))
-                                    fragment))]))
+                [(blog-page-anchor _ path anchor)
+                 (if (equal? path (get-current-site-path))
+                     (string-append "#" (uri-encode anchor))
+                     (site-path->url-string path #:fragment anchor))]))
 
             (define attrs* (attributes-union (hasheq 'href href) attrs))
             (wrap-for-style #:attrs (hasheq) `[(a ,(attributes->list attrs*) ,@rendered)])]
@@ -501,6 +512,11 @@
     ; files containing serialized `rendered-post` structures, instead.
     (define/override (get-suffix) #".info")
 
+    (define/override (get-current-site-path)
+      (define part (current-top-part))
+      (post-path (get-required-style-prop post-date? (style-properties (part-style part)))
+                 (content->string (strip-aux (part-title-content part)))))
+
     (define/override (render-one part ri output-file)
       (define props (style-properties (part-style part)))
       (define title-str (content->string (strip-aux (part-title-content part)) this part ri))
diff --git a/blog/build/render/util.rkt b/blog/build/render/util.rkt
@@ -42,6 +42,7 @@
 (define tag->anchor-name
   (match-lambda
     [(literal-anchor anchor-name) anchor-name]
+    [(cons 'part tag) (tag->anchor-name tag)]
     [(? list? elements)
      ; 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
diff --git a/blog/lang/metadata.rkt b/blog/lang/metadata.rkt
@@ -9,7 +9,8 @@
          (struct-out post-tags)
          (contract-out
           [post-date->string (-> post-date? string?)]
-          [post-date->strings (-> post-date? (list/c string? string? string?))]))
+          [post-date->strings (-> post-date? (list/c string? string? string?))]
+          [blog-post-path->tag-prefix (-> (and/c string? relative-path?) string?)]))
 
 (serializable-struct post-date (year month day) #:transparent
   #:guard (struct-guard/c exact-integer? (integer-in 1 12) (integer-in 1 31)))
@@ -23,3 +24,6 @@
   (list (~a (post-date-year date))
         (~r #:min-width 2 #:pad-string "0" (post-date-month date))
         (~r #:min-width 2 #:pad-string "0" (post-date-day date))))
+
+(define (blog-post-path->tag-prefix path)
+  (~a `(blog ,path)))
diff --git a/blog/lang/post-language.rkt b/blog/lang/post-language.rkt
@@ -7,6 +7,7 @@
          racket/contract
          racket/match
          racket/string
+         (prefix-in scribble: scribble/base)
          scribble/base
          scribble/core
          scribble/decode
@@ -20,7 +21,16 @@
          infer-date
          (struct-out post-tags)
          define-footnote
-         (contract-out [code (-> content? ... element?)]
+         (contract-out [seclink (->* [string?]
+                                     [#:doc (or/c module-path? #f)
+                                      #:post (or/c string? #f)
+                                      #:tag-prefixes (or/c (listof string?) #f)
+                                      #:indirect? any/c]
+                                     #:rest (listof pre-content?)
+                                     element?)]
+                       [other-post (-> string? element?)]
+
+                       [code (-> content? ... element?)]
                        [code-block (-> content? ... block?)]
                        (struct pygments-content ([source string?] [language string?]))
                        [pygments (-> #:language string? string? ... element?)]
@@ -45,6 +55,24 @@
 
 ;; -----------------------------------------------------------------------------
 
+(define (seclink tag
+                 #:doc [module-path #f]
+                 #:post [post-path #f]
+                 #:tag-prefixes [prefixes #f]
+                 #:indirect? [indirect? #f]
+                 . pre-content)
+  (apply scribble:seclink tag pre-content
+         #:doc module-path
+         #:tag-prefixes (if post-path
+                            (cons (blog-post-path->tag-prefix post-path) (or prefixes '()))
+                            prefixes)
+         #:indirect? indirect?))
+
+(define (other-post post-path)
+  (seclink "top" #:post post-path))
+
+;; -----------------------------------------------------------------------------
+
 (define (code . content)
   (element (style #f (list (alt-tag "code"))) content))
 
diff --git a/blog/markdown/to-scribble.rkt b/blog/markdown/to-scribble.rkt
@@ -10,7 +10,12 @@
          scribble/decode-struct
          scribble/html-properties
 
-         "../lang/post-language.rkt"
+         (only-in "../lang/post-language.rkt"
+                  code
+                  code-block
+                  footnote-flow
+                  footnote-reference-element
+                  pygments-block)
          (prefix-in md: "parse.rkt"))
 
 (provide (contract-out
diff --git a/blog/paths.rkt b/blog/paths.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
-(require racket/contract
+(require net/url
+         racket/contract
          racket/format
          racket/runtime-path
          racket/string
@@ -14,13 +15,15 @@
           [posts-dir path?]
 
           [site-path? predicate/c]
+          [site-path->url-string (->* [site-path?] [#:fragment (or/c string? #f)] string?)]
+          [full-url (->* [site-path?] [#:fragment (or/c string? #f)] string?)]
+
           [index-path (->* [] [exact-positive-integer?
                                #:tag (or/c string? #f)
                                #:file? any/c]
                            site-path?)]
           [post-path (->* [post-date? string?] [#:file? any/c] site-path?)]
-          [feed-path (->* [(or/c 'atom 'rss)] [#:tag (or/c string? #f)] site-path?)]
-          [full-url (-> site-path? string?)]))
+          [feed-path (->* [(or/c 'atom 'rss)] [#:tag (or/c string? #f)] site-path?)]))
 
 (define-runtime-path build-dir-base "../build")
 (define-runtime-path output-dir-base "../output")
@@ -33,6 +36,18 @@
   (and (string? v)
        (absolute-path? v)))
 
+(define (site-path->url-string path #:fragment [fragment #f])
+  (url->string (struct-copy url (path->url path)
+                            [scheme #f]
+                            [host #f]
+                            [fragment fragment])))
+
+(define (full-url path #:fragment [fragment #f])
+  (url->string (struct-copy url (path->url path)
+                            [scheme "https"]
+                            [host "lexi-lambda.github.io"]
+                            [fragment #f])))
+
 (define (index-path [page-number 1]
                     #:tag [tag #f]
                     #:file? [file? #f])
@@ -51,6 +66,3 @@
 
 (define (feed-path format #:tag [tag #f])
   (~a "/feeds/" (if tag (to-slug tag) "all") "." format ".xml"))
-
-(define (full-url path)
-  (~a "https://lexi-lambda.github.io" path))
diff --git a/blog/posts/about-me.scrbl b/blog/posts/about-me.scrbl
@@ -1,8 +1,6 @@
 #lang scribble/base
 @(begin
    (require racket/list
-            scribble/core
-            scribble/html-properties
             threading
             "../lang/post-language.rkt")
 
