suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Some racketization (and outdent).

Browse Source 
original commit: 34ec39119442c4202e3779a929b8406aee58e524
This commit is contained in:
Eli Barzilay 2012-05-06 06:29:18 -04:00
parent c3d02f1416
commit 6bec5dbd28
1 changed files with 186 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

382
collects/scribble/text-render.rkt
View File

@ -1,213 +1,201 @@
(module text-render racket/base #lang racket/base
(require "core.rkt" (require "core.rkt"
racket/class racket/class
racket/port) racket/port
(provide render-mixin) racket/list)
(provide render-mixin)
(define current-preserve-spaces (make-parameter #f)) (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)))
(define (indent) (define (indent)
(let ([i (current-indent)]) (define i (current-indent))
(unless (zero? i) (unless (zero? i) (display (make-string i #\space))))
(display (make-string i #\space))))) (define (indented-newline)
(define (indented-newline) (newline)
(newline) (indent))
(indent))
(define indent-pxs (make-hash)) (define indent-pxs (make-hash))
(define (indent->paragraph-px amt) (define (indent->paragraph-px amt)
(or (hash-ref indent-pxs amt #f) (or (hash-ref indent-pxs amt #f)
(let ([px (pregexp (format "^ *(.{1,~a}(?<! ))(?: |$)" (- 72 amt)))]) (let ([px (pregexp (format "^ *(.{1,~a}(?<! ))(?: |$)" (- 72 amt)))])
(hash-set! indent-pxs amt px) (hash-set! indent-pxs amt px)
px))) px)))
(define (render-mixin %) (define (render-mixin %)
(class % (class %
(define/override (current-render-mode) (define/override (current-render-mode)
'(text)) '(text))
(define/override (get-substitutions) (define/override (get-substitutions)
'((#rx"---" "\U2014") '((#rx"---" "\U2014")
(#rx"--" "\U2013") (#rx"--" "\U2013")
(#rx"``" "\U201C") (#rx"``" "\U201C")
(#rx"''" "\U201D") (#rx"''" "\U201D")
(#rx"'" "\U2019"))) (#rx"'" "\U2019")))
(inherit render-block) (inherit render-block)
(define/override (render-part d ht) (define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d ht))]) (let ([number (collected-info-number (part-collected-info d ht))])
(for-each (lambda (n) (for ([n (in-list (reverse number))] #:when n) (printf "~s." n))
(when n (when (part-title-content d)
(printf "~s." n))) (when (ormap values number) (printf " "))
(reverse number)) (render-content (part-title-content d) d ht))
(when (part-title-content d) (when (or (ormap values number) (part-title-content d))
(when (ormap values number) (newline)
(printf " ")) (newline))
(render-content (part-title-content d) d ht)) (render-flow (part-blocks d) d ht #f)
(when (or (ormap values number) (let loop ([pos 1]
(part-title-content d)) [secs (part-parts d)]
(newline) [need-newline? (pair? (part-blocks d))])
(newline)) (unless (null? secs)
(render-flow (part-blocks d) d ht #f) (when need-newline? (newline))
(let loop ([pos 1] (render-part (car secs) ht)
[secs (part-parts d)] (loop (add1 pos) (cdr secs) #t)))))
[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?) (define/override (render-flow f part ht starting-item?)
(if (null? f) (if (null? f)
null null
(apply (append*
append (render-block (car f) part ht starting-item?)
(render-block (car f) part ht starting-item?) (for/list ([p (in-list (cdr f))])
(map (lambda (p) (indented-newline)
(indented-newline) (render-block p part ht #f)))))
(render-block p part ht #f))
(cdr f)))))
(define/override (render-intrapara-block p part ri first? last? starting-item?) (define/override (render-intrapara-block p part ri first? last? starting-item?)
(unless first? (indented-newline)) (unless first? (indented-newline))
(super render-intrapara-block p part ri first? last? starting-item?)) (super render-intrapara-block p part ri first? last? starting-item?))
(define/override (render-table i part ht inline?) (define/override (render-table i part ht inline?)
(let ([flowss (table-blockss i)]) (define flowss (table-blockss i))
(if (null? flowss) (if (null? flowss)
null null
(let* ([strs (map (lambda (flows) (let* ([strs (map (lambda (flows)
(map (lambda (d) (map (lambda (d)
(if (eq? d 'cont) (if (eq? d 'cont)
d d
(let ([o (open-output-string)]) (let ([o (open-output-string)])
(parameterize ([current-indent 0] (parameterize ([current-indent 0]
[current-output-port o]) [current-output-port o])
(render-block d part ht #f)) (render-block d part ht #f))
(regexp-split (regexp-split
#rx"\n" #rx"\n"
(regexp-replace #rx"\n$" (get-output-string o) ""))))) (regexp-replace #rx"\n$" (get-output-string o) "")))))
flows)) flows))
flowss)] flowss)]
[widths (map (lambda (col) [widths (map (lambda (col)
(for/fold ([d 0]) ([i (in-list col)]) (for/fold ([d 0]) ([i (in-list col)])
(if (eq? i 'cont) (if (eq? i 'cont)
0 0
(apply max d (map string-length i))))) (apply max d (map string-length i)))))
(apply map list strs))] (apply map list strs))]
[x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))]) [x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
(for/fold ([indent? #f]) ([row (in-list strs)]) (for/fold ([indent? #f]) ([row (in-list strs)])
(let ([h (apply max 0 (map x-length row))]) (let ([h (apply max 0 (map x-length row))])
(let ([row* (for/list ([i (in-range h)]) (let ([row* (for/list ([i (in-range h)])
(for/list ([col (in-list row)]) (for/list ([col (in-list row)])
(if (i . < . (x-length col)) (if (i . < . (x-length col))
(list-ref col i) (list-ref col i)
"")))]) "")))])
(for/fold ([indent? indent?]) ([sub-row (in-list row*)]) (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)])
; (when space? (display " "))
(let ([col (if (eq? col 'cont)
""
col)])
(display 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
(apply append
(begin
(printf "* ")
(parameterize ([current-indent (make-indent 2)])
(render-flow (car flows) part ht #t)))
(map (lambda (d)
(indented-newline)
(printf "* ")
(parameterize ([current-indent (make-indent 2)])
(render-flow d part ht #f)))
(cdr flows))))))
(define/override (render-paragraph p part ri)
(let ([o (open-output-string)])
(parameterize ([current-output-port o])
(super render-paragraph p part ri))
(let ([i (open-input-string
(regexp-replace* #rx"\n" (get-output-string o) " "))]
[px (indent->paragraph-px (current-indent))])
(let loop ([indent? #f])
(cond
[(or (regexp-try-match px i)
(regexp-try-match #px"^ *(.+(?<! ))(?: |$)" i))
=> (lambda (m)
(when indent? (indent))
(write-bytes (cadr m))
(newline)
(loop #t))]
[else
(regexp-try-match "^ +" i)
(let ([b (read-byte i)])
(unless (eof-object? b)
(when indent? (indent)) (when indent? (indent))
(write-byte b) (for/fold ([space? #f])
(copy-port i (current-output-port)) ([col (in-list sub-row)]
(newline)))]))) [w (in-list widths)])
null)) ;; (when space? (display " "))
(let ([col (if (eq? col 'cont) "" col)])
(display col)
(display (make-string (max 0 (- w (string-length col))) #\space)))
#t)
(newline)
#t)))
#t)
null)))
(define/override (render-content i part ri) (define/override (render-itemization i part ht)
(if (and (element? i) (let ([flows (itemization-blockss i)])
(let ([s (element-style i)]) (if (null? flows)
(or (eq? 'hspace s) null
(and (style? s) (append*
(eq? 'hspace (style-name s)))))) (begin (printf "* ")
(parameterize ([current-preserve-spaces #t]) (parameterize ([current-indent (make-indent 2)])
(super render-content i part ri)) (render-flow (car flows) part ht #t)))
(super render-content i part ri))) (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-nested-flow i part ri starting-item?) (define/override (render-paragraph p part ri)
(let ([s (nested-flow-style i)]) (define o (open-output-string))
(if (and s (parameterize ([current-output-port o])
(or (eq? (style-name s) 'inset) (super render-paragraph p part ri))
(eq? (style-name s) 'code-inset))) (define i (open-input-string
(begin (regexp-replace* #rx"\n" (get-output-string o) " ")))
(printf " ") (define px (indent->paragraph-px (current-indent)))
(parameterize ([current-indent (make-indent 2)]) (let loop ([indent? #f])
(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 (cond
[(symbol? i) [(or (regexp-try-match px i)
(display (case i (regexp-try-match #px"^ *(.+(?<! ))(?: |$)" i))
[(mdash) "\U2014"] => (lambda (m)
[(ndash) "\U2013"] (when indent? (indent))
[(ldquo) "\U201C"] (write-bytes (cadr m))
[(rdquo) "\U201D"] (newline)
[(rsquo) "\U2019"] (loop #t))]
[(lang) ">"] [else
[(rang) "<"] (regexp-try-match "^ +" i)
[(rarr) "->"] (define b (read-byte i))
[(nbsp) "\uA0"] (unless (eof-object? b)
[(prime) "'"] (when indent? (indent))
[(alpha) "\u03B1"] (write-byte b)
[(infin) "\u221E"] (copy-port i (current-output-port))
[else (error 'text-render "unknown element symbol: ~e" i)]))] (newline))]))
[(string? i) (if (current-preserve-spaces) null)
(display (regexp-replace* #rx" " i "\uA0"))
(display i))]
[else (write i)])
null)
(super-new)))) (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))
(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"]
[(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)))