text-render.rkt (13883B)
1 #lang racket/base 2 (require "core.rkt" 3 "base-render.rkt" 4 "private/render-utils.rkt" 5 racket/class racket/port racket/list racket/string 6 scribble/text/wrap) 7 (provide render-mixin) 8 9 (define current-preserve-spaces (make-parameter #f)) 10 11 (define current-indent (make-parameter 0)) 12 (define (make-indent amt) 13 (+ amt (current-indent))) 14 (define (indent) 15 (define i (current-indent)) 16 (unless (zero? i) (display (make-string i #\space)))) 17 (define (indented-newline) 18 (newline) 19 (indent)) 20 21 (define render-mixin 22 (mixin (render<%>) () 23 24 (define/override (current-render-mode) 25 '(text)) 26 27 (define/override (get-substitutions) 28 '((#rx"---" "\U2014") 29 (#rx"--" "\U2013") 30 (#rx"``" "\U201C") 31 (#rx"''" "\U201D") 32 (#rx"'" "\U2019"))) 33 34 (inherit render-block 35 format-number) 36 37 (define/override (render-part d ht) 38 (let ([number (collected-info-number (part-collected-info d ht))]) 39 (unless (part-style? d 'hidden) 40 (let ([s (format-number number '() #t)]) 41 (unless (null? s) 42 (printf "~a~a" 43 (car s) 44 (if (part-title-content d) 45 " " 46 ""))) 47 (when (part-title-content d) 48 (render-content (part-title-content d) d ht)) 49 (when (or (pair? number) (part-title-content d)) 50 (newline) 51 (newline)))) 52 (render-flow (part-blocks d) d ht #f) 53 (let loop ([pos 1] 54 [secs (part-parts d)] 55 [need-newline? (pair? (part-blocks d))]) 56 (unless (null? secs) 57 (when need-newline? (newline)) 58 (render-part (car secs) ht) 59 (loop (add1 pos) (cdr secs) #t))))) 60 61 (define/override (render-flow f part ht starting-item?) 62 (if (null? f) 63 null 64 (append* 65 (render-block (car f) part ht starting-item?) 66 (for/list ([p (in-list (cdr f))]) 67 (indented-newline) 68 (render-block p part ht #f))))) 69 70 (define/override (render-intrapara-block p part ri first? last? starting-item?) 71 (unless first? (indented-newline)) 72 (super render-intrapara-block p part ri first? last? starting-item?)) 73 74 (define/override (render-table i part ht inline?) 75 (define flowss (table-blockss i)) 76 (if (null? flowss) 77 null 78 (let* ([strs (map (lambda (flows) 79 (map (lambda (d) 80 (if (eq? d 'cont) 81 d 82 (let ([o (open-output-string)]) 83 (parameterize ([current-indent 0] 84 [current-output-port o]) 85 (render-block d part ht #f)) 86 (regexp-split 87 #rx"\n" 88 (regexp-replace #rx"\n$" (get-output-string o) ""))))) 89 flows)) 90 flowss)] 91 [extract-align 92 (lambda (s) 93 (define p (style-properties s)) 94 (cond 95 [(member 'right p) 'right] 96 [(member 'center p) 'center] 97 [else 'left]))] 98 [alignss 99 (cond 100 [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i))) 101 => (lambda (tc) 102 (for/list ([l (in-list (table-cells-styless tc))]) 103 (for/list ([s (in-list l)]) 104 (extract-align s))))] 105 [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i))) 106 => (lambda (tc) 107 (make-list 108 (length flowss) 109 (for/list ([s (in-list (table-columns-styles tc))]) 110 (extract-align s))))] 111 [else 112 (if (null? flowss) 113 null 114 (make-list (length flowss) (make-list (length (car flowss)) 'left)))])] 115 [extract-border 116 (lambda (s) 117 (define p (style-properties s)) 118 (cond 119 [(memq 'border p) '#(#t #t #t #t)] 120 [else 121 (vector (memq 'left-border p) (memq 'right-border p) 122 (memq 'top-border p) (memq 'bottom-border p))]))] 123 [borderss 124 ;; A border is (vector left? right? top? bottom?) 125 (cond 126 [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i))) 127 => (lambda (tc) 128 (for/list ([l (in-list (table-cells-styless tc))]) 129 (for/list ([s (in-list l)]) 130 (extract-border s))))] 131 [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i))) 132 => (lambda (tc) 133 (make-list 134 (length flowss) 135 (for/list ([s (in-list (table-columns-styles tc))]) 136 (extract-border s))))] 137 [else 138 (if (null? flowss) 139 null 140 (make-list (length flowss) (make-list (length (car flowss)) '#(#f #f #f #f))))])] 141 [border-left? (lambda (v) (vector-ref v 0))] 142 [border-right? (lambda (v) (vector-ref v 1))] 143 [border-top? (lambda (v) (vector-ref v 2))] 144 [border-bottom? (lambda (v) (vector-ref v 3))] 145 [col-borders ; has only left and right 146 (for/list ([i (in-range (length (car borderss)))]) 147 (for/fold ([v '#(#f #f)]) ([borders (in-list borderss)]) 148 (define v2 (list-ref borders i)) 149 (vector (or (border-left? v) (border-left? v2)) 150 (or (border-right? v) (border-right? v2)))))] 151 [widths (map (lambda (col) 152 (for/fold ([d 0]) ([i (in-list col)]) 153 (if (eq? i 'cont) 154 d 155 (apply max d (map string-length i))))) 156 (apply map list strs))] 157 [x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))]) 158 159 (define (show-row-border prev-borders borders) 160 (when (for/or ([prev-border (in-list prev-borders)] 161 [border (in-list borders)]) 162 (or (border-bottom? prev-border) 163 (border-top? border))) 164 (define-values (end-h-border? end-v-border?) 165 (for/fold ([left-border? #f] 166 [prev-border? #f]) 167 ([w (in-list widths)] 168 [prev-border (in-list prev-borders)] 169 [border (in-list borders)] 170 [col-border (in-list col-borders)]) 171 (define border? (or (and prev-border (border-bottom? prev-border)) 172 (border-top? border))) 173 (when (or left-border? (border-left? col-border)) 174 (display (if (or prev-border? border?) "-" " "))) 175 (display (make-string w (if border? #\- #\space))) 176 (values (border-right? col-border) border?))) 177 (when end-h-border? 178 (display (if end-v-border? "-" " "))) 179 (newline))) 180 181 (define-values (last-indent? last-borders) 182 (for/fold ([indent? #f] [prev-borders #f]) ([row (in-list strs)] 183 [aligns (in-list alignss)] 184 [borders (in-list borderss)]) 185 (values 186 (let ([h (apply max 0 (map x-length row))]) 187 (let ([row* (for/list ([i (in-range h)]) 188 (for/list ([col (in-list row)]) 189 (if (i . < . (x-length col)) 190 (list-ref col i) 191 (if (eq? col 'cont) 192 'cont 193 ""))))]) 194 (for/fold ([indent? indent?]) ([sub-row (in-list row*)] 195 [pos (in-naturals)]) 196 (when indent? (indent)) 197 198 (when (zero? pos) 199 (show-row-border (or prev-borders (map (lambda (b) '#(#f #f #f #f)) borders)) 200 borders)) 201 202 (define-values (end-border? end-col-border?) 203 (for/fold ([left-border? #f] [left-col-border? #f]) 204 ([col (in-list sub-row)] 205 [w (in-list widths)] 206 [align (in-list aligns)] 207 [border (in-list borders)] 208 [col-border (in-list col-borders)]) 209 (when (or left-col-border? (border-left? col-border)) 210 (display (if (and (or left-border? (border-left? border)) 211 (not (eq? col 'cont))) 212 "|" 213 " "))) 214 (let ([col (if (eq? col 'cont) "" col)]) 215 (define gap (max 0 (- w (string-length col)))) 216 (case align 217 [(right) (display (make-string gap #\space))] 218 [(center) (display (make-string (quotient gap 2) #\space))]) 219 (display col) 220 (case align 221 [(left) (display (make-string gap #\space))] 222 [(center) (display (make-string (- gap (quotient gap 2)) #\space))])) 223 (values (border-right? border) 224 (border-right? col-border)))) 225 (when end-col-border? 226 (display (if end-border? "|" " "))) 227 (newline) 228 #t))) 229 borders))) 230 231 (show-row-border last-borders (map (lambda (b) '#(#f #f #f #f)) last-borders)) 232 233 null))) 234 235 (define/override (render-itemization i part ht) 236 (let ([flows (itemization-blockss i)]) 237 (if (null? flows) 238 null 239 (append* 240 (begin (printf "* ") 241 (parameterize ([current-indent (make-indent 2)]) 242 (render-flow (car flows) part ht #t))) 243 (for/list ([d (in-list (cdr flows))]) 244 (indented-newline) 245 (printf "* ") 246 (parameterize ([current-indent (make-indent 2)]) 247 (render-flow d part ht #f))))))) 248 249 (define/override (render-paragraph p part ri) 250 (define o (open-output-string)) 251 (parameterize ([current-output-port o]) 252 (super render-paragraph p part ri)) 253 (define to-wrap (regexp-replace* #rx"\n" (get-output-string o) " ")) 254 (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent)))) 255 (write-string (car lines)) 256 (for ([line (in-list (cdr lines))]) 257 (newline) (indent) (write-string line)) 258 (newline) 259 null) 260 261 (define/override (render-content i part ri) 262 (if (and (element? i) 263 (let ([s (element-style i)]) 264 (or (eq? 'hspace s) 265 (and (style? s) 266 (eq? 'hspace (style-name s)))))) 267 (parameterize ([current-preserve-spaces #t]) 268 (super render-content i part ri)) 269 (super render-content i part ri))) 270 271 (define/override (render-nested-flow i part ri starting-item?) 272 (define s (nested-flow-style i)) 273 (unless (memq 'decorative (style-properties s)) 274 (if (and s (or (eq? (style-name s) 'inset) 275 (eq? (style-name s) 'code-inset))) 276 (begin (printf " ") 277 (parameterize ([current-indent (make-indent 2)]) 278 (super render-nested-flow i part ri starting-item?))) 279 (super render-nested-flow i part ri starting-item?)))) 280 281 (define/override (render-other i part ht) 282 (cond 283 [(symbol? i) 284 (display (case i 285 [(mdash) "\U2014"] 286 [(ndash) "\U2013"] 287 [(ldquo) "\U201C"] 288 [(rdquo) "\U201D"] 289 [(lsquo) "\U2018"] 290 [(rsquo) "\U2019"] 291 [(lang) ">"] 292 [(rang) "<"] 293 [(rarr) "->"] 294 [(nbsp) "\uA0"] 295 [(prime) "'"] 296 [(alpha) "\u03B1"] 297 [(infin) "\u221E"] 298 [else (error 'text-render "unknown element symbol: ~e" i)]))] 299 [(string? i) (if (current-preserve-spaces) 300 (display (regexp-replace* #rx" " i "\uA0")) 301 (display i))] 302 [else (write i)]) 303 null) 304 305 (super-new)))