306 lines
14 KiB
Racket
306 lines
14 KiB
Racket
#lang racket/base
|
|
(require "core.rkt"
|
|
"base-render.rkt"
|
|
"private/render-utils.rkt"
|
|
racket/class racket/port racket/list racket/string
|
|
scribble/text/wrap)
|
|
(provide render-mixin)
|
|
|
|
(define current-preserve-spaces (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 render-mixin
|
|
(mixin (render<%>) ()
|
|
|
|
(define/override (current-render-mode)
|
|
'(text))
|
|
|
|
(define/override (get-substitutions)
|
|
'((#rx"---" "\U2014")
|
|
(#rx"--" "\U2013")
|
|
(#rx"``" "\U201C")
|
|
(#rx"''" "\U201D")
|
|
(#rx"'" "\U2019")))
|
|
|
|
(inherit render-block
|
|
format-number)
|
|
|
|
(define/override (render-part d ht)
|
|
(let ([number (collected-info-number (part-collected-info d ht))])
|
|
(unless (part-style? d 'hidden)
|
|
(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))
|
|
(if (null? flowss)
|
|
null
|
|
(let* ([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)]
|
|
[extract-align
|
|
(lambda (s)
|
|
(define p (style-properties s))
|
|
(cond
|
|
[(member 'right p) 'right]
|
|
[(member 'center p) 'center]
|
|
[else 'left]))]
|
|
[alignss
|
|
(cond
|
|
[(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
|
|
=> (lambda (tc)
|
|
(for/list ([l (in-list (table-cells-styless tc))])
|
|
(for/list ([s (in-list l)])
|
|
(extract-align s))))]
|
|
[(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
|
|
=> (lambda (tc)
|
|
(make-list
|
|
(length flowss)
|
|
(for/list ([s (in-list (table-columns-styles tc))])
|
|
(extract-align s))))]
|
|
[else
|
|
(if (null? flowss)
|
|
null
|
|
(make-list (length flowss) (make-list (length (car flowss)) 'left)))])]
|
|
[extract-border
|
|
(lambda (s)
|
|
(define p (style-properties s))
|
|
(cond
|
|
[(memq 'border p) '#(#t #t #t #t)]
|
|
[else
|
|
(vector (memq 'left-border p) (memq 'right-border p)
|
|
(memq 'top-border p) (memq 'bottom-border p))]))]
|
|
[borderss
|
|
;; A border is (vector left? right? top? bottom?)
|
|
(cond
|
|
[(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
|
|
=> (lambda (tc)
|
|
(for/list ([l (in-list (table-cells-styless tc))])
|
|
(for/list ([s (in-list l)])
|
|
(extract-border s))))]
|
|
[(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
|
|
=> (lambda (tc)
|
|
(make-list
|
|
(length flowss)
|
|
(for/list ([s (in-list (table-columns-styles tc))])
|
|
(extract-border s))))]
|
|
[else
|
|
(if (null? flowss)
|
|
null
|
|
(make-list (length flowss) (make-list (length (car flowss)) '#(#f #f #f #f))))])]
|
|
[border-left? (lambda (v) (vector-ref v 0))]
|
|
[border-right? (lambda (v) (vector-ref v 1))]
|
|
[border-top? (lambda (v) (vector-ref v 2))]
|
|
[border-bottom? (lambda (v) (vector-ref v 3))]
|
|
[col-borders ; has only left and right
|
|
(for/list ([i (in-range (length (car borderss)))])
|
|
(for/fold ([v '#(#f #f)]) ([borders (in-list borderss)])
|
|
(define v2 (list-ref borders i))
|
|
(vector (or (border-left? v) (border-left? v2))
|
|
(or (border-right? v) (border-right? v2)))))]
|
|
[widths (map (lambda (col)
|
|
(for/fold ([d 0]) ([i (in-list col)])
|
|
(if (eq? i 'cont)
|
|
d
|
|
(apply max d (map string-length i)))))
|
|
(apply map list strs))]
|
|
[x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
|
|
|
|
(define (show-row-border prev-borders borders)
|
|
(when (for/or ([prev-border (in-list prev-borders)]
|
|
[border (in-list borders)])
|
|
(or (border-bottom? prev-border)
|
|
(border-top? border)))
|
|
(define-values (end-h-border? end-v-border?)
|
|
(for/fold ([left-border? #f]
|
|
[prev-border? #f])
|
|
([w (in-list widths)]
|
|
[prev-border (in-list prev-borders)]
|
|
[border (in-list borders)]
|
|
[col-border (in-list col-borders)])
|
|
(define border? (or (and prev-border (border-bottom? prev-border))
|
|
(border-top? border)))
|
|
(when (or left-border? (border-left? col-border))
|
|
(display (if (or prev-border? border?) "-" " ")))
|
|
(display (make-string w (if border? #\- #\space)))
|
|
(values (border-right? col-border) border?)))
|
|
(when end-h-border?
|
|
(display (if end-v-border? "-" " ")))
|
|
(newline)))
|
|
|
|
(define-values (last-indent? last-borders)
|
|
(for/fold ([indent? #f] [prev-borders #f]) ([row (in-list strs)]
|
|
[aligns (in-list alignss)]
|
|
[borders (in-list borderss)])
|
|
(values
|
|
(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)
|
|
(if (eq? col 'cont)
|
|
'cont
|
|
""))))])
|
|
(for/fold ([indent? indent?]) ([sub-row (in-list row*)]
|
|
[pos (in-naturals)])
|
|
(when indent? (indent))
|
|
|
|
(when (zero? pos)
|
|
(show-row-border (or prev-borders (map (lambda (b) '#(#f #f #f #f)) borders))
|
|
borders))
|
|
|
|
(define-values (end-border? end-col-border?)
|
|
(for/fold ([left-border? #f] [left-col-border? #f])
|
|
([col (in-list sub-row)]
|
|
[w (in-list widths)]
|
|
[align (in-list aligns)]
|
|
[border (in-list borders)]
|
|
[col-border (in-list col-borders)])
|
|
(when (or left-col-border? (border-left? col-border))
|
|
(display (if (and (or left-border? (border-left? border))
|
|
(not (eq? col 'cont)))
|
|
"|"
|
|
" ")))
|
|
(let ([col (if (eq? col 'cont) "" col)])
|
|
(define gap (max 0 (- w (string-length col))))
|
|
(case align
|
|
[(right) (display (make-string gap #\space))]
|
|
[(center) (display (make-string (quotient gap 2) #\space))])
|
|
(display col)
|
|
(case align
|
|
[(left) (display (make-string gap #\space))]
|
|
[(center) (display (make-string (- gap (quotient gap 2)) #\space))]))
|
|
(values (border-right? border)
|
|
(border-right? col-border))))
|
|
(when end-col-border?
|
|
(display (if end-border? "|" " ")))
|
|
(newline)
|
|
#t)))
|
|
borders)))
|
|
|
|
(show-row-border last-borders (map (lambda (b) '#(#f #f #f #f)) last-borders))
|
|
|
|
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 o (open-output-string))
|
|
(parameterize ([current-output-port o])
|
|
(super render-paragraph p part ri))
|
|
(define to-wrap (regexp-replace* #rx"\n" (get-output-string o) " "))
|
|
(define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
|
|
(write-string (car lines))
|
|
(for ([line (in-list (cdr lines))])
|
|
(newline) (indent) (write-string line))
|
|
(newline)
|
|
null)
|
|
|
|
(define/override (render-content i part ri)
|
|
(if (and (element? i)
|
|
(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))
|
|
(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))
|
|
(if (and s (or (eq? (style-name s) 'inset)
|
|
(eq? (style-name s) 'code-inset)))
|
|
(begin (printf " ")
|
|
(parameterize ([current-indent (make-indent 2)])
|
|
(super render-nested-flow i part ri starting-item?)))
|
|
(super render-nested-flow i part ri starting-item?))))
|
|
|
|
(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 'text-render "unknown element symbol: ~e" i)]))]
|
|
[(string? i) (if (current-preserve-spaces)
|
|
(display (regexp-replace* #rx" " i "\uA0"))
|
|
(display i))]
|
|
[else (write i)])
|
|
null)
|
|
|
|
(super-new)))
|