390 lines
15 KiB
Racket
390 lines
15 KiB
Racket
#lang racket/base
|
||
(require "core.rkt"
|
||
"base-render.rkt"
|
||
"private/render-utils.rkt"
|
||
racket/class racket/port racket/list racket/string racket/match
|
||
scribble/text/wrap)
|
||
(provide render-mixin
|
||
current-markdown-link-sections)
|
||
|
||
(define current-markdown-link-sections (make-parameter #f))
|
||
|
||
(define current-indent (make-parameter 0))
|
||
(define (make-indent amt)
|
||
(+ amt (current-indent)))
|
||
(define (indent)
|
||
(define i (current-indent))
|
||
(unless (zero? i) (display (make-string i #\space))))
|
||
(define (indented-newline)
|
||
(newline)
|
||
(indent))
|
||
|
||
(define note-depth (make-parameter 0))
|
||
(define in-toc (make-parameter #f))
|
||
|
||
(define markdown-part-tag 'markdown-section)
|
||
|
||
(define (render-mixin %)
|
||
(class %
|
||
|
||
(define/override (current-render-mode)
|
||
'(markdown))
|
||
|
||
(define/override (get-suffix) #".md")
|
||
|
||
(define/override (get-substitutions)
|
||
'((#rx"---" "\U2014")
|
||
(#rx"--" "\U2013")
|
||
(#rx"``" "\U201C")
|
||
(#rx"''" "\U201D")
|
||
(#rx"'" "\U2019")))
|
||
|
||
(inherit render-block
|
||
format-number
|
||
number-depth)
|
||
|
||
(define/override (collect-part-tags d ci number)
|
||
(for ([t (part-tags d)])
|
||
(let ([t (generate-tag t ci)])
|
||
(collect-put! ci
|
||
t
|
||
(vector (or (part-title-content d) '("???"))
|
||
(add-current-tag-prefix t)
|
||
number
|
||
markdown-part-tag)))))
|
||
|
||
(define/override (render-part d ht)
|
||
(let ([number (collected-info-number (part-collected-info d ht))])
|
||
(unless (part-style? d 'hidden)
|
||
(printf (string-append (make-string (add1 (number-depth number)) #\#) " "))
|
||
(let ([s (format-number number '() #t)])
|
||
(unless (null? s)
|
||
(printf "~a~a"
|
||
(car s)
|
||
(if (part-title-content d)
|
||
" "
|
||
"")))
|
||
(when (part-title-content d)
|
||
(render-content (part-title-content d) d ht))
|
||
(when (or (pair? number) (part-title-content d))
|
||
(newline)
|
||
(newline))))
|
||
(render-flow (part-blocks d) d ht #f)
|
||
(let loop ([pos 1]
|
||
[secs (part-parts d)]
|
||
[need-newline? (pair? (part-blocks d))])
|
||
(unless (null? secs)
|
||
(when need-newline? (newline))
|
||
(render-part (car secs) ht)
|
||
(loop (add1 pos) (cdr secs) #t)))))
|
||
|
||
(define/override (render-flow f part ht starting-item?)
|
||
(if (null? f)
|
||
null
|
||
(append*
|
||
(render-block (car f) part ht starting-item?)
|
||
(for/list ([p (in-list (cdr f))])
|
||
(indented-newline)
|
||
(render-block p part ht #f)))))
|
||
|
||
(define/override (render-intrapara-block p part ri first? last? starting-item?)
|
||
(unless first? (indented-newline))
|
||
(super render-intrapara-block p part ri first? last? starting-item?))
|
||
|
||
(define/override (render-table i part ht inline?)
|
||
(define flowss (table-blockss i))
|
||
|
||
(define tick? (member (style-name (table-style i))
|
||
(list 'boxed "defmodule" "RktBlk")))
|
||
|
||
(cond
|
||
[(null? flowss) null]
|
||
|
||
[(and tick? (not (in-code?)))
|
||
(displayln "```racket")
|
||
(parameterize ([in-code? #t])
|
||
(render-table i part ht inline?))
|
||
(displayln "```")]
|
||
|
||
[else
|
||
(define strs (map (lambda (flows)
|
||
(map (lambda (d)
|
||
(if (eq? d 'cont)
|
||
d
|
||
(let ([o (open-output-string)])
|
||
(parameterize ([current-indent 0]
|
||
[current-output-port o])
|
||
(render-block d part ht #f))
|
||
(regexp-split
|
||
#rx"\n"
|
||
(regexp-replace #rx"\n$"
|
||
(get-output-string o)
|
||
"")))))
|
||
flows))
|
||
flowss))
|
||
(define widths (map (lambda (col)
|
||
(for/fold ([d 0]) ([i (in-list col)])
|
||
(if (eq? i 'cont)
|
||
0
|
||
(apply max d (map string-length i)))))
|
||
(apply map list strs)))
|
||
(define x-length (lambda (col) (if (eq? col 'cont) 0 (length col))))
|
||
(for/fold ([indent? #f]) ([row (in-list strs)])
|
||
(let ([h (apply max 0 (map x-length row))])
|
||
(let ([row* (for/list ([i (in-range h)])
|
||
(for/list ([col (in-list row)])
|
||
(if (i . < . (x-length col))
|
||
(list-ref col i)
|
||
"")))])
|
||
(for/fold ([indent? indent?]) ([sub-row (in-list row*)])
|
||
(when indent? (indent))
|
||
(for/fold ([space? #f])
|
||
([col (in-list sub-row)]
|
||
[w (in-list widths)])
|
||
(let ([col (if (eq? col 'cont) "" col)])
|
||
(display (regexp-replace* #rx"\uA0" col " "))
|
||
(display (make-string (max 0 (- w (string-length col))) #\space)))
|
||
#t)
|
||
(newline)
|
||
#t)))
|
||
#t)])
|
||
null)
|
||
|
||
(define/override (render-itemization i part ht)
|
||
(let ([flows (itemization-blockss i)])
|
||
(if (null? flows)
|
||
null
|
||
(append*
|
||
(begin (printf "* ")
|
||
(parameterize ([current-indent (make-indent 2)])
|
||
(render-flow (car flows) part ht #t)))
|
||
(for/list ([d (in-list (cdr flows))])
|
||
(indented-newline)
|
||
(printf "* ")
|
||
(parameterize ([current-indent (make-indent 2)])
|
||
(render-flow d part ht #f)))))))
|
||
|
||
(define/override (render-paragraph p part ri)
|
||
(define (write-note)
|
||
(write-string (make-string (note-depth) #\>))
|
||
(unless (zero? (note-depth))
|
||
(write-string " ")))
|
||
(cond
|
||
[(in-toc)
|
||
(write-note)
|
||
(super render-paragraph p part ri)
|
||
;; two spaces at a line end creates a line break:
|
||
(write-string " ")]
|
||
[else
|
||
(define o (open-output-string))
|
||
(parameterize ([current-output-port o])
|
||
(super render-paragraph p part ri))
|
||
;; 1. Remove newlines so we can re-wrap the text.
|
||
;;
|
||
;; 2. Combine adjacent code spans into one. These result from
|
||
;; something like @racket[(x y)] being treated as multiple
|
||
;; RktXXX items rather than one. (Although it would be
|
||
;; more-correct to handle them at that level, I don't easily see
|
||
;; how. As a result I'm handling it after-the-fact, at the
|
||
;; text/Markdown stage.)
|
||
(define to-wrap (regexp-replaces (get-output-string o)
|
||
'([#rx"\n" " "] ;1
|
||
[#rx"``" ""]))) ;2
|
||
(define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
|
||
(write-note)
|
||
(write-string (car lines))
|
||
(for ([line (in-list (cdr lines))])
|
||
(newline) (indent) (write-note) (write-string line))])
|
||
(newline)
|
||
null)
|
||
|
||
(define/private (content-style e)
|
||
(cond
|
||
[(element? e) (element-style e)]
|
||
[(multiarg-element? e) (multiarg-element-style e)]
|
||
[else #f]))
|
||
|
||
(define in-bold? (make-parameter #f))
|
||
(define in-italic? (make-parameter #f))
|
||
(define in-code? (make-parameter #f))
|
||
(define in-link? (make-parameter #f))
|
||
(define preserving-spaces? (make-parameter #f))
|
||
|
||
(define (bold? i)
|
||
(and (element? i) (eq? (element-style i) 'bold)))
|
||
|
||
(define (italic? i)
|
||
(and (element? i) (eq? (element-style i) 'italic)))
|
||
|
||
(define (emph? i)
|
||
(and (element? i) (eq? (element-style i) 'emph)))
|
||
|
||
(define (code? i)
|
||
(and (element? i)
|
||
(let ([s (element-style i)])
|
||
(or (eq? 'tt s)
|
||
(and (style? s)
|
||
(style-name s)
|
||
(regexp-match? #rx"^Rkt[A-Z]" (style-name s)))))))
|
||
|
||
(define (link? i)
|
||
(let ([s (content-style i)])
|
||
(and (style? s) (findf target-url? (style-properties s)))))
|
||
|
||
(define (link-from i)
|
||
(target-url-addr (findf target-url? (style-properties (content-style i)))))
|
||
|
||
(define (preserve-spaces? i)
|
||
(and (element? i)
|
||
(let ([s (element-style i)])
|
||
(or (eq? 'hspace s)
|
||
(and (style? s)
|
||
(eq? 'hspace (style-name s)))))))
|
||
|
||
(define (sanitize-parens str)
|
||
(regexp-replace #rx"[\\(\\)]" str "\\&"))
|
||
|
||
(define/override (render-content i part ri)
|
||
(define (recurse-wrapped str param)
|
||
(display str)
|
||
(begin0
|
||
(parameterize ([param #t])
|
||
(render-content i part ri))
|
||
(display str)))
|
||
|
||
(cond
|
||
[(and (code? i) (not (in-code?)))
|
||
(recurse-wrapped "`" in-code?)]
|
||
|
||
[(and (bold? i) (not (in-bold?)) (not (in-code?)))
|
||
(recurse-wrapped "**" in-bold?)]
|
||
|
||
[(and (italic? i) (not (in-italic?)) (not (in-code?)))
|
||
(recurse-wrapped "_" in-italic?)]
|
||
|
||
[(and (emph? i) (not (in-code?)))
|
||
(display "_") ;; zero-width space, underscore
|
||
(begin0
|
||
(super render-content i part ri)
|
||
(display "_"))] ;; underscore, zero-width space
|
||
|
||
[(and (preserve-spaces? i) (not (preserving-spaces?)))
|
||
(parameterize ([preserving-spaces? #t])
|
||
(render-content i part ri))]
|
||
|
||
[(and (link? i) (not (in-link?)))
|
||
(let ([link (link-from i)])
|
||
(display "[")
|
||
(begin0
|
||
(parameterize ([in-link? #t])
|
||
(render-content i part ri))
|
||
(printf "](~a)" (sanitize-parens link))))]
|
||
|
||
[(and (link-element? i)
|
||
(current-markdown-link-sections)
|
||
(not (in-link?))
|
||
;; Link to a part within this document?
|
||
(let ([vec (resolve-get part ri (link-element-tag i))])
|
||
(and (vector? vec)
|
||
(= 4 (vector-length vec))
|
||
(eq? markdown-part-tag (vector-ref vec 3))
|
||
vec)))
|
||
=> (lambda (vec)
|
||
(define s (string-append
|
||
(let ([s (if (vector-ref vec 2)
|
||
(format-number (vector-ref vec 2) '() #t)
|
||
'())])
|
||
(if (null? s)
|
||
""
|
||
(string-append (car s) " ")))
|
||
(content->string (vector-ref vec 0))))
|
||
(display "[")
|
||
(begin0
|
||
(parameterize ([in-link? #t])
|
||
(super render-content i part ri))
|
||
(display "](#")
|
||
(display (regexp-replace* #" "
|
||
(regexp-replace* #rx"[^a-zA-Z0-9_ -]" (string-downcase s) "")
|
||
#"-"))
|
||
(display ")")))]
|
||
|
||
[else (super render-content i part ri)]))
|
||
|
||
(define/override (render-nested-flow i part ri starting-item?)
|
||
(define s (nested-flow-style i))
|
||
(unless (memq 'decorative (style-properties s))
|
||
(define note? (equal? (style-name s) "refcontent"))
|
||
(define toc? (equal? (style-name s) 'table-of-contents))
|
||
(when note?
|
||
(note-depth (add1 (note-depth))))
|
||
(begin0 (parameterize ([in-toc (or toc? (in-toc))])
|
||
(super render-nested-flow i part ri starting-item?))
|
||
(when note?
|
||
(note-depth (sub1 (note-depth)))))))
|
||
|
||
(define/override (render-other i part ht)
|
||
(cond
|
||
[(symbol? i)
|
||
(display (case i
|
||
[(mdash) "\U2014"]
|
||
[(ndash) "\U2013"]
|
||
[(ldquo) "\U201C"]
|
||
[(rdquo) "\U201D"]
|
||
[(lsquo) "\U2018"]
|
||
[(rsquo) "\U2019"]
|
||
[(lang) "<"]
|
||
[(rang) ">"]
|
||
[(rarr) "->"]
|
||
[(nbsp) "\uA0"]
|
||
[(prime) "'"]
|
||
[(alpha) "\u03B1"]
|
||
[(infin) "\u221E"]
|
||
[else (error 'markdown-render "unknown element symbol: ~e"
|
||
i)]))]
|
||
[(string? i)
|
||
(let* ([i (cond
|
||
[(in-code?)
|
||
(regexp-replace** i '([#rx"``" . "\U201C"]
|
||
[#rx"''" . "\U201D"]))]
|
||
[(or (in-link?)
|
||
(regexp-match? #rx"^[(]" i)
|
||
(regexp-match? #rx"[]][(]" i))
|
||
(regexp-replace* #px"([#_*`\\[\\(\\]\\)]{1})" i "\\\\\\1")]
|
||
[else
|
||
;; Avoid escaping parentheses
|
||
(regexp-replace* #px"([#_*`\\[\\]]{1})" i "\\\\\\1")])]
|
||
[i (if (preserving-spaces?)
|
||
(regexp-replace* #rx" " i "\uA0")
|
||
i)])
|
||
(display i))]
|
||
[else (write i)])
|
||
null)
|
||
|
||
(define/override (table-of-contents part ri)
|
||
(define t (super table-of-contents part ri))
|
||
(cond
|
||
[(current-markdown-link-sections)
|
||
;; Table generated by `table-of-contents` always has one
|
||
;; column, and each row has one paragraph that starts
|
||
;; with a 'hspace element to indent
|
||
(nested-flow
|
||
(style 'table-of-contents null)
|
||
(for/list ([p (map car (table-blockss t))])
|
||
(define c (paragraph-content p))
|
||
(define keep-c (cdr c))
|
||
(define (spaces->depth n)
|
||
(add1 (quotient (- n 4) 2)))
|
||
(for/fold ([p (paragraph plain keep-c)]) ([s (in-range
|
||
(spaces->depth
|
||
(string-length (car (element-content (car c))))))])
|
||
(nested-flow (style "refcontent" null) (list p)))))]
|
||
[else t]))
|
||
|
||
(super-new)))
|
||
|
||
(define (regexp-replace** str ptns&reps)
|
||
(for/fold ([str str])
|
||
([ptn (map car ptns&reps)]
|
||
[rep (map cdr ptns&reps)])
|
||
(regexp-replace* ptn str rep)))
|