suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

refactor markdown renderer a bit

Browse Source 
* favor recursion for wrapping text in markdown notation
* simplify params to just bool, use parameterize with recursion
This commit is contained in:
Alex Suraci 2015-04-27 23:21:29 -07:00 committed by Matthew Flatt
parent 117218dc3e
commit fc08b7ba49
1 changed files with 111 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

209
scribble-lib/scribble/markdown-render.rkt
View File

@ -6,8 +6,6 @@
scribble/text/wrap) scribble/text/wrap)
(provide render-mixin) (provide render-mixin)
(define current-preserve-spaces (make-parameter #f))
(define current-indent (make-parameter 0)) (define current-indent (make-parameter 0))
(define (make-indent amt) (define (make-indent amt)
(+ amt (current-indent))) (+ amt (current-indent)))
@ -18,8 +16,6 @@
(newline) (newline)
(indent)) (indent))
(define table-ticks-depth (make-parameter 0))
(define phrase-ticks-depth (make-parameter 0))
(define note-depth (make-parameter 0)) (define note-depth (make-parameter 0))
(define (render-mixin %) (define (render-mixin %)
@ -81,59 +77,61 @@
(define/override (render-table i part ht inline?) (define/override (render-table i part ht inline?)
(define flowss (table-blockss i)) (define flowss (table-blockss i))
(unless (null? flowss)
;; Set table-ticks-depth prior to render-block calls (define tick? (member (style-name (table-style i))
(define tick? (member (style-name (table-style i)) (list 'boxed "defmodule" "RktBlk")))
(list 'boxed "defmodule" "RktBlk")))
(when tick? (cond
(when (zero? (table-ticks-depth)) [(null? flowss) null]
(displayln "```racket"))
(table-ticks-depth (add1 (table-ticks-depth)))) [(and tick? (not (in-code?)))
(define strs (map (lambda (flows) (displayln "```racket")
(map (lambda (d) (parameterize ([in-code? #t])
(if (eq? d 'cont) (render-table i part ht inline?))
d (displayln "```")]
(let ([o (open-output-string)])
(parameterize ([current-indent 0] [else
[current-output-port o]) (define strs (map (lambda (flows)
(render-block d part ht #f)) (map (lambda (d)
(regexp-split (if (eq? d 'cont)
#rx"\n" d
(regexp-replace #rx"\n$" (let ([o (open-output-string)])
(get-output-string o) (parameterize ([current-indent 0]
""))))) [current-output-port o])
flows)) (render-block d part ht #f))
flowss)) (regexp-split
(define widths (map (lambda (col) #rx"\n"
(for/fold ([d 0]) ([i (in-list col)]) (regexp-replace #rx"\n$"
(if (eq? i 'cont) (get-output-string o)
0 "")))))
(apply max d (map string-length i))))) flows))
(apply map list strs))) flowss))
(define x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))) (define widths (map (lambda (col)
(for/fold ([indent? #f]) ([row (in-list strs)]) (for/fold ([d 0]) ([i (in-list col)])
(let ([h (apply max 0 (map x-length row))]) (if (eq? i 'cont)
(let ([row* (for/list ([i (in-range h)]) 0
(for/list ([col (in-list row)]) (apply max d (map string-length i)))))
(if (i . < . (x-length col)) (apply map list strs)))
(list-ref col i) (define x-length (lambda (col) (if (eq? col 'cont) 0 (length col))))
"")))]) (for/fold ([indent? #f]) ([row (in-list strs)])
(for/fold ([indent? indent?]) ([sub-row (in-list row*)]) (let ([h (apply max 0 (map x-length row))])
(when indent? (indent)) (let ([row* (for/list ([i (in-range h)])
(for/fold ([space? #f]) (for/list ([col (in-list row)])
([col (in-list sub-row)] (if (i . < . (x-length col))
[w (in-list widths)]) (list-ref col i)
(let ([col (if (eq? col 'cont) "" col)]) "")))])
(display (regexp-replace* #rx"\uA0" col " ")) (for/fold ([indent? indent?]) ([sub-row (in-list row*)])
(display (make-string (max 0 (- w (string-length col))) #\space))) (when indent? (indent))
#t) (for/fold ([space? #f])
(newline) ([col (in-list sub-row)]
#t))) [w (in-list widths)])
#t) (let ([col (if (eq? col 'cont) "" col)])
(when tick? (display (regexp-replace* #rx"\uA0" col " "))
(table-ticks-depth (sub1 (table-ticks-depth))) (display (make-string (max 0 (- w (string-length col))) #\space)))
(when (zero? (table-ticks-depth)) #t)
(displayln "```")))) (newline)
#t)))
#t)])
null) null)
(define/override (render-itemization i part ht) (define/override (render-itemization i part ht)
@ -183,25 +181,60 @@
[(multiarg-element? e) (multiarg-element-style e)] [(multiarg-element? e) (multiarg-element-style e)]
[else #f])) [else #f]))
(define in-bold? (make-parameter #f))
(define in-italic? (make-parameter #f))
(define in-code? (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 (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 (preserve-spaces? i)
(and (element? i)
(let ([s (element-style i)])
(or (eq? 'hspace s)
(and (style? s)
(eq? 'hspace (style-name s)))))))
(define/override (render-content i part ri) (define/override (render-content i part ri)
(define tick? (define (recurse-wrapped str param)
(and (zero? (table-ticks-depth)) (display str)
(element? i) (begin0
(let ([s (element-style i)]) (parameterize ([param #t])
(or (eq? 'tt s) (render-content i part ri))
(and (style? s) (display str)))
(style-name s)
(regexp-match? #rx"^Rkt[A-Z]" (style-name s))))))) (cond
(when tick? [(and (code? i) (not (in-code?)))
(when (zero? (phrase-ticks-depth)) (recurse-wrapped "`" in-code?)]
(display "`"))
(phrase-ticks-depth (add1 (phrase-ticks-depth)))) [(and (bold? i) (not (in-bold?)))
(define properties (let ([s (content-style i)]) (recurse-wrapped "**" in-bold?)]
(if (style? s) (style-properties s) '())))
(define targ (for/or ([p properties]) [(and (italic? i) (not (in-italic?)))
(if (target-url? p) p #f))) (recurse-wrapped "_" in-italic?)]
(define url (and targ (target-url-addr targ)))
(begin0 [(and (preserve-spaces? i) (not (preserving-spaces?)))
(parameterize ([preserving-spaces? #t])
(render-content i part ri))]
[else
(define properties (let ([s (content-style i)])
(if (style? s) (style-properties s) '())))
(define targ (for/or ([p properties])
(if (target-url? p) p #f)))
(define url (and targ (target-url-addr targ)))
(cond [url (define new-i (cond [url (define new-i
(match (element-content i) (match (element-content i)
[(list (? string? s)) [(list (? string? s))
@ -209,26 +242,7 @@
(list (format "[~a](~a)" s url)))] (list (format "[~a](~a)" s url)))]
[else i])) [else i]))
(super render-content new-i part ri)] (super render-content new-i part ri)]
[(and (element? i) [else (super render-content i part ri)])]))
(let ([s (element-style i)])
(or (eq? 'hspace s)
(and (style? s)
(eq? 'hspace (style-name s))))))
(parameterize ([current-preserve-spaces #t])
(super render-content i part ri))]
[else (define style (and (element? i) (element-style i)))
(define bold? (eq? style 'bold))
(define italic? (eq? style 'italic))
(cond [bold? (display "**")]
[italic? (display "_")])
(begin0
(super render-content i part ri)
(cond [bold? (display "**")]
[italic? (display "_")]))])
(when tick?
(phrase-ticks-depth (sub1 (phrase-ticks-depth)))
(when (zero? (phrase-ticks-depth))
(display "`")))))
(define/override (render-nested-flow i part ri starting-item?) (define/override (render-nested-flow i part ri starting-item?)
(define s (nested-flow-style i)) (define s (nested-flow-style i))
@ -260,12 +274,11 @@
[else (error 'markdown-render "unknown element symbol: ~e" [else (error 'markdown-render "unknown element symbol: ~e"
i)]))] i)]))]
[(string? i) [(string? i)
(let* ([i (if (or (not (zero? (phrase-ticks-depth))) (let* ([i (if (in-code?)
(not (zero? (table-ticks-depth))))
(regexp-replace** i '([#rx"``" . "\U201C"] (regexp-replace** i '([#rx"``" . "\U201C"]
[#rx"''" . "\U201D"])) [#rx"''" . "\U201D"]))
(regexp-replace* #px"([#_*`]{1})" i "\\\\\\1"))] (regexp-replace* #px"([#_*`]{1})" i "\\\\\\1"))]
[i (if (current-preserve-spaces) [i (if (preserving-spaces?)
(regexp-replace* #rx" " i "\uA0") (regexp-replace* #rx" " i "\uA0")
i)]) i)])
(display i))] (display i))]