racket-commonmark/commonmark-lib/commonmark/render/html.rkt at 4970c1decb92ee8902c9ee4115180700c897349f · lexi-lambda/racket-commonmark · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
#lang racket/base

(require net/uri-codec
         racket/class
         racket/contract
         racket/format
         racket/list
         racket/match
         threading
         (except-in xml document document? struct:document)

         "../private/render.rkt"
         "../private/struct.rkt")

(provide (contract-out
          [document->xexprs (-> document? (listof xexpr/c))]
          [document->html (-> document? string?)]
          [write-document-html (->* [document?] [output-port?] void?)]

          [current-bold-tag (parameter/c symbol?)]
          [current-italic-tag (parameter/c symbol?)]))

;; -----------------------------------------------------------------------------

(define current-bold-tag (make-parameter 'strong))
(define current-italic-tag (make-parameter 'em))

(define (document->html doc)
  (define out (open-output-string))
  (write-document-html doc out #:who 'document->html)
  (get-output-string out))

(define (write-document-html doc [out (current-output-port)] #:who [who 'write-document-html])
  (parameterize ([empty-tag-shorthand html-empty-tags])
    (for ([xexpr (in-list (document->xexprs doc #:who who))])
      (write-xexpr xexpr out))))

(define (document->xexprs doc #:who [who 'document->xexprs])
  (send (new html-render% [doc doc] [who who]) render-document))

(define html-render%
  (class abstract-render%
    (define/override (render-document)
      (define-values [body footnotes] (super render-document))
      (if (empty? footnotes)
          body
          `[,@body
            (section ([class "footnotes"])
                     (ol ,@footnotes))]))

    (define/override (render-thematic-break)
      '(hr))
    (define/override (render-heading content depth)
      `(,(vector-ref #(h1 h2 h3 h4 h5 h6) (sub1 depth)) ,@content))
    (define/override (render-code-block content language)
      `(pre (code ,@(if language
                        `(([class ,(string-append "language-" language)]))
                        '())
                  ,content)))
    (define/override (render-html-block content)
      (cdata #f #f content))
    (define/override (render-paragraph content)
      `(p ,@content))
    (define/override (render-blockquote blocks)
      `(blockquote ,@blocks))
    (define/override (render-itemization blockss style start-num)
      `(,(if start-num 'ol 'ul)
        ,@(match start-num
            [(or #f 1) '()]
            [_ `(([start ,(~a start-num)]))])
        ,@(for/list ([blocks (in-list blockss)])
            `(li ,@blocks))))

    (define/override (render-line-break)
      '(br))
    (define/override (render-bold content)
      `(,(current-bold-tag) ,@content))
    (define/override (render-italic content)
      `(,(current-italic-tag) ,@content))
    (define/override (render-code content)
      `(code ,content))
    (define/override (render-link content dest title)
      `(a ([href ,dest]
           ,@(if title
                 `([title ,title])
                 '()))
          ,@content))
    (define/override (render-image description source title)
      `(img ([src ,source]
             [alt ,description]
             ,@(if title
                   `([title ,title])
                   '()))))
    (define/override (render-html content)
      (cdata #f #f content))
    (define/override (render-footnote-reference label defn-num ref-num)
      `(sup ([class "footnote-ref"])
            (a ([id ,(footnote-reference-anchor label ref-num)]
                [href ,(~a "#" (footnote-definition-anchor (uri-path-segment-encode label)))])
               ,(~a defn-num))))
    (define/override (render-wikilink content dest)
      `(a ([href ,dest]) ,@content))

    (define/override (render-footnote-definition blocks label ref-count)
      (define encoded-label (uri-path-segment-encode label))
      (define multiple-refs? (> ref-count 1))
      (define backrefs (~> (for/list ([i (in-range ref-count)])
                             (define ref-num (add1 i))
                             `(a ([class "footnote-backref"]
                                  [href ,(~a "#" (footnote-reference-anchor encoded-label ref-num))]
                                  [aria-label ,(~a "Jump to reference"
                                                   (if multiple-refs? (~a " (" ref-num ")") ""))])
                                 "↩" ,@(if multiple-refs? `((sup ,(~a ref-num))) '())))
                           (add-between " ")
                           (cons " " _)))

      `(li ([id ,(footnote-definition-anchor label)])
           ,@(match blocks
               [(list block ... (list 'p inline ...))
                `(,@block (p ,@inline ,@backrefs))]
               [_
                (append blocks backrefs)])))

    (define/public (footnote-definition-anchor label)
      (~a "fn-" label))
    (define/public (footnote-reference-anchor label ref-num)
      (~a "fnref-" label (if (= ref-num 1) "" (~a "-" ref-num))))

    (super-new)))