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

A complete rewrite of text output using port state now.

Browse Source 
Also a few more text-controlling primitives.

svn: r14065

original commit: ca30b05114115470136c32dc8a2fca34e6ceb1d8
This commit is contained in:
Eli Barzilay 2009-03-12 02:27:12 +00:00
parent fd1bb626d6
commit d1f1c4011d
1 changed files with 154 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

231
collects/scribble/text/output.ss
View File

@ -2,107 +2,180 @@
(require scheme/promise) (require scheme/promise)
(provide output verbatim unverbatim prefix) (provide output splice verbatim unverbatim flush prefix)
;; Outputs some value, for the preprocessor langauge.
;;
;; Uses global state because `output' is wrapped around each expression in a
;; scribble/text file so this is much more convenient than wrapping the whole
;; module's body in a `list' (which will be difficult with definitions etc).
;; The state is a pair of prefixes -- one that is the prefix for the current
;; value (which gets accumulated to with nested lists), and the other is the
;; prefix for the current "line" (which is reset after a newline). The
;; line-prefix is needed because a line can hold a list, which means that the
;; line-prefix will apply for the contents of the list including newlines in
;; it. This state is associated to a port via a hash table. Another state
;; that is used is the port's column position, which is maintained by the
;; system (when line counts are enabled) -- this is used to tell what part of a
;; prefix is already displayed.
;;
;; Each prefix is either an integer (for a number of spaces), a string, or #f
;; indicating that prefixes are disabled (different from 0 -- they will not be
;; accumulated).
;;
(define (output x [p (current-output-port)]) (define (output x [p (current-output-port)])
;; these are the global prefix and the one that is local to the current line
(define pfxs (port->state p))
;; to get the output column
(define (getcol) (let-values ([(line col pos) (port-next-location p)]) col)) (define (getcol) (let-values ([(line col pos) (port-next-location p)]) col))
(port-count-lines! p) ;; total size of the two prefixes
;; pfx can be a column number, or a byte-string, or #f for nothing at all (define (2pfx-length pfx1 pfx2)
(let loop ([x x] [pfx (getcol)]) (if (and pfx1 pfx2)
;; new can be a new target column number or an additional prefix to add (a (+ (if (number? pfx1) pfx1 (string-length pfx1))
;; string or a byte string) (if (number? pfx2) pfx2 (string-length pfx2)))
(define (combine-pfx pfx new) 0))
(and pfx new ;; combines a prefix with a target column to get to
(if (number? pfx) (define (pfx+col pfx)
(if (number? new) (and pfx (let ([col (getcol)])
;; new target column (cond [(number? pfx) (max pfx col)]
(max pfx new) [(>= (string-length pfx) col) pfx]
;; add a prefix to existing column [else (string-append
(bytes-append (make-spaces pfx) pfx (make-spaces (- col (string-length pfx))))]))))
(if (string? new) (string->bytes/utf-8 new) new))) ;; adds two prefixes
(if (number? new) (define (pfx+ pfx1 pfx2)
;; add spaces to get to the target column after (and pfx1 pfx2
(let ([cur (bytes-length pfx)]) (if (and (number? pfx1) (number? pfx2)) (+ pfx1 pfx2)
(if (new . > . cur) (string-append (if (number? pfx1) (make-spaces pfx1) pfx1)
(bytes-append pfx (make-spaces (- new cur))) (if (number? pfx2) (make-spaces pfx2) pfx2)))))
pfx)) ;; prints two prefixes
;; append prefixes (define (output-pfx col pfx1 pfx2)
(bytes-append pfx (if (string? new) (define-syntax-rule (->str pfx) (if (number? pfx) (make-spaces pfx) pfx))
(string->bytes/utf-8 new) (define-syntax-rule (show pfx) ; optimize when not needed
new)))))) (unless (eq? pfx 0) (write-string (->str pfx) p)))
;; used to output strings and byte strings, where each internal newline (when (and pfx1 pfx2)
;; should be followed by the prefix (if (eq? 0 col)
(define (do-string write get-length nl-rx) (begin (show pfx1) (show pfx2))
(define len (get-length x)) (let ([len1 (if (number? pfx1) pfx1 (string-length pfx1))])
(define ms (and pfx (or (bytes? pfx) (pfx . > . 0)) (len . > . 0) (cond [(< col len1) (write-string (->str pfx1) p col) (show pfx2)]
(regexp-match-positions* nl-rx x))) [(= col len1) (show pfx2)]
(if (pair? ms) [(eq? 0 pfx2)]
(let ([pfx (if (bytes? pfx) pfx (make-spaces pfx))]) [else
(let loop ([start 0] [ms ms]) (let ([col (- col len1)]
(let ([i (cdar ms)]) [len2 (if (number? pfx2) pfx2 (string-length pfx2))])
(write x p start i) (when (< col len2) (write-string (->str pfx2) p col )))])))))
(when (< i len) ;; main loop
(write-bytes pfx p) (define (loop x)
(if (null? (cdr ms))
(write x p i)
(loop i (cdr ms)))))))
(write x p)))
(cond (cond
;; no output for these ;; no output for these
[(or (void? x) (not x) (null? x)) (void)] [(or (void? x) (not x) (null? x)) (void)]
;; for lists and pairs the indentation at the beginning is used, then ;; for lists and pairs the current line prefix is added to the global
;; output the contents recursively ;; one, then output the contents recursively (no need to change the
[(pair? x) (let ([pfx (combine-pfx pfx (getcol))]) ;; state, since we pass the values in the loop, and we'd need to restore
;; it afterwards anyway)
[(pair? x) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
[npfx (pfx+col (pfx+ pfx lpfx))])
(set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
(if (list? x) (if (list? x)
(for ([x (in-list x)]) (loop x pfx)) (for ([x (in-list x)]) (loop x))
(begin (loop (car x) pfx) (loop (cdr x) pfx))))] (let ploop ([x x])
(if (pair? x)
(begin (loop (car x)) (ploop (cdr x)))
(loop x))))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
;; delayed values ;; delayed values
[(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x) pfx)] [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
[(promise? x) (loop (force x) pfx)] [(promise? x) (loop (force x))]
;; special output wrappers ;; special output wrappers
[(special? x) [(special? x)
(let ([c (special-contents x)]) (let ([c (special-contents x)])
(case (special-flag x) (case (special-flag x)
[(verbatim) (loop c #f)] [(splice) (for-each loop c)]
[(unverbatim) (loop c (getcol))] [(verbatim) ; save the previous pfxs
(let ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)])
(set-mcar! pfxs #f) (set-mcdr! pfxs (cons pfx lpfx))
(for-each loop c)
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
[(unverbatim) ; restore the previous pfxs
(let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
[npfx (pfx+col (if (and (not pfx) (pair? lpfx))
(pfx+ (car lpfx) (cdr lpfx))
(pfx+ pfx lpfx)))])
(set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
(for-each loop c)
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
[(flush) ; useful before verbatim
(output-pfx (getcol) (mcar pfxs) (mcdr pfxs))]
[(prefix) [(prefix)
(let ([pfx (combine-pfx (combine-pfx pfx (getcol)) (car c))]) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
;; could also do: (loop (cdr c) pfx), but save time [npfx (pfx+ (pfx+col (pfx+ pfx lpfx)) (car c))])
(for ([x (in-list (cdr c))]) (loop x pfx)))] (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
(for ([x (in-list (cdr c))]) (loop x))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
[else (error 'output "unknown special value flag: ~e" [else (error 'output "unknown special value flag: ~e"
(special-flag x))]))] (special-flag x))]))]
;; the rest will cause some output, so show the prefix and go [else
[else (when pfx (let* ([x (cond [(string? x) x]
(let ([cur (getcol)]) [(bytes? x) (bytes->string/utf-8 x)]
(if (number? pfx) [(symbol? x) (symbol->string x)]
;; number: add spaces to get to that column [(path? x) (path->string x)]
(let ([n (- pfx cur)]) [(keyword? x) (keyword->string x)]
(when (> n 0) (write-bytes (make-spaces n) p))) [(number? x) (number->string x)]
;; prefix: omit characters from the prefix that we went past [(char? x) (string x)]
(cond [(zero? cur) (write-bytes pfx p)]
[(< cur (bytes-length pfx)) (write-bytes pfx p cur)]))))
(cond
;; strings output indentation in internal newlines too
[(string? x) (do-string write-string string-length #rx"\n")]
[(bytes? x) (do-string write-bytes bytes-length #rx#"\n")]
;; additional values that are displayed as usual
[(symbol? x) (display x p)]
[(char? x) (write-char x p)]
[(number? x) (write x p)]
;; useful to represent attributes with keywords (same as symbols)
[(keyword? x) (write-string (keyword->string x) p)]
;; generic fallback: throw an error ;; generic fallback: throw an error
[else (error 'output "don't know how to render value: ~v" x)])])) [else (error 'output "don't know how to render value: ~v"
x)])]
[len (string-length x)]
[nls (regexp-match-positions* #rx"\n" x)]
[pfx (mcar pfxs)])
(let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)])
(cond [(pair? nls)
(let ([nl (car nls)])
(output-pfx col pfx lpfx)
(write-string x p start (cdr nl))
(loop (cdr nl) (cdr nls) 0 0))]
;; last substring from here (always set lpfx state when done)
[(start . = . len)
(set-mcdr! pfxs lpfx)]
[(col . > . (2pfx-length pfx lpfx))
(set-mcdr! pfxs lpfx)
;; the prefix was already shown, no accumulation needed
(write-string x p start)]
[else
(let ([m (regexp-match-positions #rx"^ +" x start)])
;; accumulate spaces to lpfx, display if it's not all spaces
(let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)])
(set-mcdr! pfxs lpfx)
(unless (and m (= len (cdar m)))
(output-pfx col pfx lpfx)
;; the spaces were already added to lpfx
(write-string x p (if m (cdar m) start)))))])))]))
;;
(port-count-lines! p)
(loop x)
(void)) (void))
(define port->state
(let ([t (make-weak-hasheq)]
[last '(#f #f)]) ; cache for the last port, to avoid a hash lookup
(lambda (p)
(if (eq? p (car last)) (cdr last)
(let ([s (or (hash-ref t p #f)
(let ([s (mcons 0 0)]) (hash-set! t p s) s))])
(set! last (cons p s))
s)))))
(define-struct special (flag contents)) (define-struct special (flag contents))
(define (splice . contents) (make-special 'splice contents))
(define (verbatim . contents) (make-special 'verbatim contents)) (define (verbatim . contents) (make-special 'verbatim contents))
(define (unverbatim . contents) (make-special 'unverbatim contents)) (define (unverbatim . contents) (make-special 'unverbatim contents))
(define flush (make-special 'flush #f))
(define (prefix pfx . contents) (make-special 'prefix (cons pfx contents))) (define (prefix pfx . contents) (make-special 'prefix (cons pfx contents)))
(define make-spaces (define make-spaces ; (efficiently)
(let ([t (make-hasheq)]) (let ([t (make-hasheq)] [v (make-vector 80 #f)])
(lambda (n) (lambda (n)
(or (hash-ref t n #f) (or (if (< n 80) (vector-ref v n) (hash-ref t n #f))
(let ([spaces (make-bytes n 32)]) (hash-set! t n spaces) spaces))))) (let ([spaces (make-string n #\space)])
(if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces))
spaces)))))