suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 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

384
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->paragraph-px amt)
(or (hash-ref indent-pxs amt #f)
(let ([px (pregexp (format "^ *(.{1,~a}(?<! ))(?: |$)" (- 72 amt)))])
(hash-set! indent-pxs amt px)
px)))
(define (render-mixin %) (define indent-pxs (make-hash))
(class % (define (indent->paragraph-px amt)
(or (hash-ref indent-pxs amt #f)
(define/override (current-render-mode) (let ([px (pregexp (format "^ *(.{1,~a}(?<! ))(?: |$)" (- 72 amt)))])
'(text)) (hash-set! indent-pxs amt px)
px)))
(define/override (get-substitutions) (define (render-mixin %)
'((#rx"---" "\U2014") (class %
(#rx"--" "\U2013")
(#rx"``" "\U201C")
(#rx"''" "\U201D")
(#rx"'" "\U2019")))
(inherit render-block) (define/override (current-render-mode)
'(text))
(define/override (render-part d ht) (define/override (get-substitutions)
(let ([number (collected-info-number (part-collected-info d ht))]) '((#rx"---" "\U2014")
(for-each (lambda (n) (#rx"--" "\U2013")
(when n (#rx"``" "\U201C")
(printf "~s." n))) (#rx"''" "\U201D")
(reverse number)) (#rx"'" "\U2019")))
(when (part-title-content d)
(when (ormap values number)
(printf " "))
(render-content (part-title-content d) d ht))
(when (or (ormap values 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?) (inherit render-block)
(if (null? f)
null
(apply
append
(render-block (car f) part ht starting-item?)
(map (lambda (p)
(indented-newline)
(render-block p part ht #f))
(cdr f)))))
(define/override (render-intrapara-block p part ri first? last? starting-item?) (define/override (render-part d ht)
(unless first? (indented-newline)) (let ([number (collected-info-number (part-collected-info d ht))])
(super render-intrapara-block p part ri first? last? starting-item?)) (for ([n (in-list (reverse number))] #:when n) (printf "~s." n))
(when (part-title-content d)
(define/override (render-table i part ht inline?) (when (ormap values number) (printf " "))
(let ([flowss (table-blockss i)]) (render-content (part-title-content d) d ht))
(if (null? flowss) (when (or (ormap values number) (part-title-content d))
null (newline)
(let* ([strs (map (lambda (flows) (newline))
(map (lambda (d) (render-flow (part-blocks d) d ht #f)
(if (eq? d 'cont) (let loop ([pos 1]
d [secs (part-parts d)]
(let ([o (open-output-string)]) [need-newline? (pair? (part-blocks d))])
(parameterize ([current-indent 0] (unless (null? secs)
[current-output-port o]) (when need-newline? (newline))
(render-block d part ht #f)) (render-part (car secs) ht)
(regexp-split (loop (add1 pos) (cdr secs) #t)))))
#rx"\n"
(regexp-replace #rx"\n$" (get-output-string o) "")))))
flows))
flowss)]
[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))]
[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)])
; (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) (define/override (render-flow f part ht starting-item?)
(let ([flows (itemization-blockss i)]) (if (null? f)
(if (null? flows) null
null (append*
(apply append (render-block (car f) part ht starting-item?)
(begin (for/list ([p (in-list (cdr f))])
(printf "* ") (indented-newline)
(parameterize ([current-indent (make-indent 2)]) (render-block p part ht #f)))))
(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) (define/override (render-intrapara-block p part ri first? last? starting-item?)
(let ([o (open-output-string)]) (unless first? (indented-newline))
(parameterize ([current-output-port o]) (super render-intrapara-block p part ri first? last? starting-item?))
(super render-paragraph p part ri))
(let ([i (open-input-string (define/override (render-table i part ht inline?)
(regexp-replace* #rx"\n" (get-output-string o) " "))] (define flowss (table-blockss i))
[px (indent->paragraph-px (current-indent))]) (if (null? flowss)
(let loop ([indent? #f]) null
(cond (let* ([strs (map (lambda (flows)
[(or (regexp-try-match px i) (map (lambda (d)
(regexp-try-match #px"^ *(.+(?<! ))(?: |$)" i)) (if (eq? d 'cont)
=> (lambda (m) d
(when indent? (indent)) (let ([o (open-output-string)])
(write-bytes (cadr m)) (parameterize ([current-indent 0]
(newline) [current-output-port o])
(loop #t))] (render-block d part ht #f))
[else (regexp-split
(regexp-try-match "^ +" i) #rx"\n"
(let ([b (read-byte i)]) (regexp-replace #rx"\n$" (get-output-string o) "")))))
(unless (eof-object? b) flows))
flowss)]
[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))]
[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)) (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)))