Add support for footnotes as an optional extension

Author: lexi-lambda

commonmark-bench/info.rkt

@@ -1,6 +1,6 @@
 #lang info
 
-(define version "1.0")
+(define version "1.1")
 
 (define collection 'multi)
 

commonmark-doc/info.rkt

@@ -1,6 +1,6 @@
 #lang info
 
-(define version "1.0")
+(define version "1.1")
 
 (define collection 'multi)
 

commonmark-doc/scribblings/commonmark.scrbl

@@ -0,0 +1,31 @@
+.CmMdNotes {
+  font-size: small;
+  padding-left: 1em;
+}
+.CmMdNotes p {
+  margin-bottom: 0.25em;
+}
+
+.CmExample {
+  column-gap: 0.5em;
+  display: flex;
+  margin-bottom: 1em;
+  margin-top: 1em;
+}
+.CmExample > * {
+  flex: 1;
+}
+
+.CmExampleTitleLeft, .CmExampleTitleRight {
+  background-color: #eee;
+}
+.CmExampleTitleRight {
+  text-align: right;
+}
+.CmExampleTitleText {
+  padding: 0 0.5em;
+}
+
+.CmExampleContent {
+  margin: 0 0.5em;
+}

commonmark-doc/scribblings/commonmark/private/commonmark.css

@@ -0,0 +1,163 @@
+#lang racket/base
+
+;; This module implements a simple Markdown-to-Scribble renderer for the
+;; purposes of rendering examples in the commonmark library documentation.
+;;
+;; It is *not* a general-purpose solution for converting Markdown to Scribble,
+;; primarily because it explicitly avoids converting Markdown headers to
+;; Scribble `part-start` declarations, which would pollute the structure of the
+;; manual itself and would make it impossible to display rendered headings
+;; inside a nested flow.
+
+(require commonmark/parse
+         commonmark/private/render
+         racket/class
+         racket/contract
+         racket/format
+         racket/list
+         racket/match
+         racket/path
+         racket/runtime-path
+         setup/main-collects
+         scribble/core
+         scribble/html-properties
+         scribble/manual
+         threading
+         (only-in xml cdata))
+
+(provide (contract-out
+          [markdown-block (-> string? ... block?)]
+          [markdown-example (-> string? ... block?)]))
+
+;; -----------------------------------------------------------------------------
+
+(define-runtime-path commonmark.css "commonmark.css")
+(define commonmark-css-addition (~> (simple-form-path commonmark.css)
+                                    path->main-collects-relative
+                                    css-addition))
+
+(define horizontal-rule-style (style #f (list (alt-tag "hr"))))
+(define (horizontal-rule)
+  (paragraph horizontal-rule-style '()))
+
+(define inset-style (style 'inset '()))
+(define ordered-style (style 'ordered '()))
+(define div-flow-style (style #f (list (alt-tag "div"))))
+(define footnotes-style (style "CmMdNotes" (list commonmark-css-addition (alt-tag "section"))))
+(define markdown-doc-style (style "CmMdDoc" (list commonmark-css-addition (alt-tag "div"))))
+(define example-style (style "CmExample" (list commonmark-css-addition (alt-tag "div"))))
+(define example-content-style (style "CmExampleContent" (list commonmark-css-addition (alt-tag "div"))))
+(define example-title-left-style (style "CmExampleTitleLeft" (list commonmark-css-addition)))
+(define example-title-right-style (style "CmExampleTitleRight" (list commonmark-css-addition)))
+(define example-title-text-style (style "CmExampleTitleText" (list commonmark-css-addition)))
+
+(define (markdown-block . strs)
+  (nested #:style 'code-inset (document->scribble (string->document (apply string-append strs)))))
+
+(define (markdown-example . strs)
+  (define str (apply string-append strs))
+  (nested-flow
+   example-style
+   (list (nested-flow
+          div-flow-style
+          (list (paragraph example-title-left-style (list (element example-title-text-style (tt "markdown"))))
+                (nested-flow example-content-style (list (verbatim str)))))
+         (nested-flow
+          div-flow-style
+          (list (paragraph example-title-right-style (list (element example-title-text-style (tt "rendered"))))
+                (nested-flow example-content-style (list (document->scribble (string->document str)))))))))
+
+(define (document->scribble doc #:who [who 'document->scribble])
+  (send (new scribble-render% [doc doc] [who who]) render-document))
+
+(define scribble-render%
+  (class abstract-render%
+    (define/override (render-document)
+      (define-values [body footnotes] (super render-document))
+      (nested-flow
+       markdown-doc-style
+       (if (empty? footnotes)
+           body
+           (append body
+                   (list (nested-flow footnotes-style (list (itemization ordered-style footnotes))))))))
+
+    (define/override (render-thematic-break)
+      (horizontal-rule))
+    (define/override (render-heading content depth)
+      (define tag (vector-ref #("h1" "h2" "h3" "h4" "h5" "h6") (sub1 depth)))
+      (paragraph (style #f (list (alt-tag tag))) content))
+    (define/override (render-code-block content language)
+      (match language
+        ["racket" (typeset-code #:keep-lang-line? #f "#lang racket\n" content)]
+        [_        (nested #:style 'code-inset (verbatim content))]))
+    (define/override (render-html-block content)
+      (paragraph (style #f '(div omitable)) (render-html content)))
+    (define/override (render-paragraph content)
+      (paragraph plain content))
+    (define/override (render-blockquote blocks)
+      (nested inset-style blocks))
+    (define/override (render-itemization blockss list-style start-num)
+      (itemization
+       (style (cond
+                [start-num 'ordered]
+                [(eq? list-style 'tight) 'compact]
+                [else #f])
+              (match start-num
+                [(or #f 1) '()]
+                [_ (list (attributes (list (cons 'start (number->string start-num)))))]))
+       blockss))
+
+    (define/override (render-line-break)
+      (linebreak))
+    (define/override (render-bold content)
+      (element 'bold content))
+    (define/override (render-italic content)
+      (element 'italic content))
+    (define/override (render-code content)
+      (element 'tt content))
+    (define/override (render-link content dest title)
+      (element (style #f (list (make-target-url dest))) content))
+    (define/override (render-image description source title)
+      (image-element #f description source '() 1))
+    (define/override (render-html content)
+      (element (style #f (list (xexpr-property (cdata #f #f content) ""))) '()))
+    (define/override (render-footnote-reference label defn-num ref-num)
+      (~>> (~a defn-num)
+           (link-element #f _ (footnote-definition-tag label))
+           (target-element #f _ (footnote-reference-tag label ref-num))
+           (element 'superscript)))
+
+    (define/override (render-footnote-definition blocks label ref-count)
+      (define multiple-refs? (> ref-count 1))
+      (define backrefs (~> (for/list ([i (in-range ref-count)])
+                             (define ref-num (add1 i))
+                             (link-element
+                              #f
+                              (if multiple-refs?
+                                  (list "↩" (element 'superscript (~a ref-num)))
+                                  "↩")
+                              (footnote-reference-tag label ref-num)))
+                           (add-between " ")
+                           (cons " " _)))
+
+      (define target (target-element #f '() (footnote-definition-tag label)))
+      (define targeted-blocks
+        (match blocks
+          [(cons (paragraph para-style para-content) blocks)
+           (cons (paragraph para-style (list target para-content)) blocks)]
+          [_
+           (cons (paragraph plain target) blocks)]))
+
+      (match targeted-blocks
+        [(list blocks ... (paragraph para-style para-content))
+         (append blocks (list (paragraph para-style (cons para-content backrefs))))]
+        [_
+         (append targeted-blocks (list (paragraph plain backrefs)))]))
+
+    (define local-tags (make-hash))
+    (define/public (footnote-definition-tag label)
+      (list 'footnote (hash-ref! local-tags label generated-tag)))
+    (define/public (footnote-reference-tag label ref-num)
+      (list 'footnote-ref (hash-ref! local-tags (cons label ref-num) generated-tag)))
+
+    (super-new)))

commonmark-doc/scribblings/commonmark/private/scribble-render.rkt

@@ -6,4 +6,6 @@
 
 (provide (contract-out
           [read-document (-> input-port? document?)]
-          [string->document (-> string? document?)]))
+          [string->document (-> string? document?)]
+
+          [current-parse-footnotes? (parameter/c any/c boolean?)]))

commonmark-lib/commonmark/parse.rkt

@@ -13,7 +13,9 @@
          "common.rkt"
          "inline.rkt")
 
-(provide read-document string->document)
+(provide read-document
+         string->document
+         current-parse-footnotes?)
 
 ;; -----------------------------------------------------------------------------
 
@@ -47,6 +49,8 @@
 
 ;; -----------------------------------------------------------------------------
 
+(define current-parse-footnotes? (make-parameter #f (λ (x) (and x #t))))
+
 (struct o:blockquote (blocks) #:transparent)
 (struct o:list  ; see Note [Lists overview]
   (blocks       ; blocks of the current open list item, or #f if no list item
@@ -61,6 +65,7 @@
    style        ; (or/c 'tight 'loose)
    start-num)   ; (or/c exact-nonnegative-integer? #f)
   #:transparent)
+(struct o:footnote-definition (blocks label) #:transparent)
 
 ; see Note [Open lists without an open item]
 (define (accumulate-list-blockss open-list)
@@ -82,8 +87,12 @@
   (read-document (open-input-string str)))
 
 (define (read-document in)
+  (define footnotes? (current-parse-footnotes?))
+
   (define root-blocks (make-gvector))
   (define link-reference-defns (make-hash))
+  (define footnote-defns (make-gvector))
+  (define footnote-defn-labels (make-hash))
 
   ;; ---------------------------------------------------------------------------
   ;; open blocks
@@ -121,7 +130,9 @@
                          ; see Note [Open list tightness]
                          [style (if (o:list-end-blank? oc)
                                     'loose
-                                    (o:list-style oc))])]))
+                                    (o:list-style oc))])]
+           [(o:footnote-definition blocks label)
+            (o:footnote-definition (cons block blocks) label)]))
        (gvector-set! open-containers (sub1 ocs) oc*)]))
 
   (define (open-leaf! new-open-leaf)
@@ -167,26 +178,30 @@
     ; If there’s an open leaf, we need to take care to close it /before/ we
     ; remove the open container.
     (close-leaf!)
-    (add-block!
-     #:close-unentered? #f
-     (match (gvector-remove-last! open-containers)
-       [(o:blockquote blocks)
-        (blockquote (reverse blocks))]
-       [(? o:list? open-list)
-        ; see Note [Transfer `end-blank?` to parent lists]
-        (when (and (o:list-end-blank? open-list)
-                   (not (zero? (gvector-count open-containers))))
-          (define last-idx (sub1 (gvector-count open-containers)))
-          (define parent-container (gvector-ref open-containers last-idx))
-          (when (o:list? parent-container)
-            (gvector-set! open-containers
-                          last-idx
-                          (struct-copy o:list parent-container
-                                       [end-blank? #t]))))
-
-        (itemization (reverse (accumulate-list-blockss open-list))
-                     (o:list-style open-list)
-                     (o:list-start-num open-list))])))
+    (define new-block
+      (match (gvector-remove-last! open-containers)
+        [(o:blockquote blocks)
+         (blockquote (reverse blocks))]
+        [(? o:list? open-list)
+         ; see Note [Transfer `end-blank?` to parent lists]
+         (when (and (o:list-end-blank? open-list)
+                    (not (zero? (gvector-count open-containers))))
+           (define last-idx (sub1 (gvector-count open-containers)))
+           (define parent-container (gvector-ref open-containers last-idx))
+           (when (o:list? parent-container)
+             (gvector-set! open-containers
+                           last-idx
+                           (struct-copy o:list parent-container
+                                        [end-blank? #t]))))
+
+         (itemization (reverse (accumulate-list-blockss open-list))
+                      (o:list-style open-list)
+                      (o:list-start-num open-list))]
+        [(o:footnote-definition blocks label)
+         (gvector-add! footnote-defns (footnote-definition (reverse blocks) label))
+         #f]))
+    (when new-block
+      (add-block! new-block #:close-unentered? #f)))
 
   (define (unentered-containers?)
     (< entered-containers (gvector-count open-containers)))
@@ -410,7 +425,10 @@
        (close-leaf!)
        (close-unentered-containers!)
        (document (for/list ([block (in-gvector root-blocks)])
-                   (finish-block-content block)))]
+                   (finish-block-content block))
+                 (for/list ([footnote-defn (in-gvector footnote-defns)])
+                   (match-define (footnote-definition blocks label) footnote-defn)
+                   (footnote-definition (map finish-block-content blocks) label)))]
       [else
        (mode:enter-containers)]))
 
@@ -451,7 +469,9 @@
                    (open-container! (o:list '() '() indent marker-char #f #f 'tight start-num)
                                     #:enter? #f)])
                 0])]
-         [else #f])]))
+         [else #f])]
+      [(? o:footnote-definition?)
+       (try-enter-indent 4)]))
 
   (define (mode:enter-containers)
     (cond
@@ -675,6 +695,27 @@
              (open-container! (o:list '() '() indent marker-char #f #f 'tight start-num))
              (mode:content-start)])]
 
+      ;; Extension: Footnote definitions
+      [(and footnotes?
+            (regexp-try/opt-indent
+             ; This is the regexp used by _scan_footnote_definition in cmark-gfm:
+             ;   <https://github.com/github/cmark-gfm/blob/766f161ef6d61019acf3a69f5099489e7d14cd49/src/scanners.re#L323>
+             ; Note that it consumes all whitespace after the label, so it is
+             ; impossible for a footnote to start with an indented code block on the
+             ; same line as the label (but one can begin on the following line).
+             (px "^"
+                 "\\[\\^"
+                 (:group "[^]" :space: "]+")
+                 "\\]:[ \t]*")))
+       => (match-lambda
+            [(list _ _ label-bytes)
+             (define label (bytes->string/utf-8 label-bytes))
+             (define normalized-label (normalize-link-label label))
+             (unless (hash-has-key? footnote-defn-labels normalized-label)
+               (hash-set! footnote-defn-labels normalized-label label))
+             (open-container! (o:footnote-definition '() label))
+             (mode:content-start)])]
+
       ;; § 4.8 Paragraphs
       [else
        (define line (~> (read-line in 'any)
@@ -717,15 +758,20 @@
   (define (finish-block-content block)
     (match block
       [(heading content depth)
-       (heading (string->inline content link-reference-defns) depth)]
+       (heading (parse-inline content) depth)]
       [(paragraph content)
-       (paragraph (string->inline content link-reference-defns))]
+       (paragraph (parse-inline content))]
       [(blockquote blocks)
        (blockquote (map finish-block-content blocks))]
       [(itemization blockss style start-num)
        (itemization (map (λ~>> (map finish-block-content)) blockss) style start-num)]
       [_ block]))
 
+  (define (parse-inline content)
+    (string->inline content
+                    #:link-defns link-reference-defns
+                    #:footnote-defns footnote-defn-labels))
+
   (mode:line-start))
 
 ; see Note [Tabs and tab stops]