commit d1f1c4011d8cf045d990bfe045c9a9bf2be635df
parent fd1bb626d68a7a7ac963d92a9f043484fe18d9f9
Author: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 12 Mar 2009 02:27:12 +0000
A complete rewrite of text output using port state now.
Also a few more text-controlling primitives.
svn: r14065
original commit: ca30b05114115470136c32dc8a2fca34e6ceb1d8
Diffstat:
1 file changed, 154 insertions(+), 81 deletions(-)
diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss
@@ -2,107 +2,180 @@
(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)])
+ ;; 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))
- (port-count-lines! p)
- ;; pfx can be a column number, or a byte-string, or #f for nothing at all
- (let loop ([x x] [pfx (getcol)])
- ;; new can be a new target column number or an additional prefix to add (a
- ;; string or a byte string)
- (define (combine-pfx pfx new)
- (and pfx new
- (if (number? pfx)
- (if (number? new)
- ;; new target column
- (max pfx new)
- ;; add a prefix to existing column
- (bytes-append (make-spaces pfx)
- (if (string? new) (string->bytes/utf-8 new) new)))
- (if (number? new)
- ;; add spaces to get to the target column after
- (let ([cur (bytes-length pfx)])
- (if (new . > . cur)
- (bytes-append pfx (make-spaces (- new cur)))
- pfx))
- ;; append prefixes
- (bytes-append pfx (if (string? new)
- (string->bytes/utf-8 new)
- new))))))
- ;; used to output strings and byte strings, where each internal newline
- ;; should be followed by the prefix
- (define (do-string write get-length nl-rx)
- (define len (get-length x))
- (define ms (and pfx (or (bytes? pfx) (pfx . > . 0)) (len . > . 0)
- (regexp-match-positions* nl-rx x)))
- (if (pair? ms)
- (let ([pfx (if (bytes? pfx) pfx (make-spaces pfx))])
- (let loop ([start 0] [ms ms])
- (let ([i (cdar ms)])
- (write x p start i)
- (when (< i len)
- (write-bytes pfx p)
- (if (null? (cdr ms))
- (write x p i)
- (loop i (cdr ms)))))))
- (write x p)))
+ ;; total size of the two prefixes
+ (define (2pfx-length pfx1 pfx2)
+ (if (and pfx1 pfx2)
+ (+ (if (number? pfx1) pfx1 (string-length pfx1))
+ (if (number? pfx2) pfx2 (string-length pfx2)))
+ 0))
+ ;; combines a prefix with a target column to get to
+ (define (pfx+col pfx)
+ (and pfx (let ([col (getcol)])
+ (cond [(number? pfx) (max pfx col)]
+ [(>= (string-length pfx) col) pfx]
+ [else (string-append
+ pfx (make-spaces (- col (string-length pfx))))]))))
+ ;; adds two prefixes
+ (define (pfx+ pfx1 pfx2)
+ (and pfx1 pfx2
+ (if (and (number? pfx1) (number? pfx2)) (+ pfx1 pfx2)
+ (string-append (if (number? pfx1) (make-spaces pfx1) pfx1)
+ (if (number? pfx2) (make-spaces pfx2) pfx2)))))
+ ;; prints two prefixes
+ (define (output-pfx col pfx1 pfx2)
+ (define-syntax-rule (->str pfx) (if (number? pfx) (make-spaces pfx) pfx))
+ (define-syntax-rule (show pfx) ; optimize when not needed
+ (unless (eq? pfx 0) (write-string (->str pfx) p)))
+ (when (and pfx1 pfx2)
+ (if (eq? 0 col)
+ (begin (show pfx1) (show pfx2))
+ (let ([len1 (if (number? pfx1) pfx1 (string-length pfx1))])
+ (cond [(< col len1) (write-string (->str pfx1) p col) (show pfx2)]
+ [(= col len1) (show pfx2)]
+ [(eq? 0 pfx2)]
+ [else
+ (let ([col (- col len1)]
+ [len2 (if (number? pfx2) pfx2 (string-length pfx2))])
+ (when (< col len2) (write-string (->str pfx2) p col )))])))))
+ ;; main loop
+ (define (loop x)
(cond
;; no output for these
[(or (void? x) (not x) (null? x)) (void)]
- ;; for lists and pairs the indentation at the beginning is used, then
- ;; output the contents recursively
- [(pair? x) (let ([pfx (combine-pfx pfx (getcol))])
+ ;; for lists and pairs the current line prefix is added to the global
+ ;; one, then output the contents recursively (no need to change the
+ ;; 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)
- (for ([x (in-list x)]) (loop x pfx))
- (begin (loop (car x) pfx) (loop (cdr x) pfx))))]
+ (for ([x (in-list x)]) (loop x))
+ (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
- [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x) pfx)]
- [(promise? x) (loop (force x) pfx)]
+ [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
+ [(promise? x) (loop (force x))]
;; special output wrappers
[(special? x)
(let ([c (special-contents x)])
(case (special-flag x)
- [(verbatim) (loop c #f)]
- [(unverbatim) (loop c (getcol))]
+ [(splice) (for-each loop c)]
+ [(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)
- (let ([pfx (combine-pfx (combine-pfx pfx (getcol)) (car c))])
- ;; could also do: (loop (cdr c) pfx), but save time
- (for ([x (in-list (cdr c))]) (loop x pfx)))]
+ (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
+ [npfx (pfx+ (pfx+col (pfx+ pfx lpfx)) (car c))])
+ (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"
(special-flag x))]))]
- ;; the rest will cause some output, so show the prefix and go
- [else (when pfx
- (let ([cur (getcol)])
- (if (number? pfx)
- ;; number: add spaces to get to that column
- (let ([n (- pfx cur)])
- (when (> n 0) (write-bytes (make-spaces n) p)))
- ;; prefix: omit characters from the prefix that we went past
- (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
- [else (error 'output "don't know how to render value: ~v" x)])]))
+ [else
+ (let* ([x (cond [(string? x) x]
+ [(bytes? x) (bytes->string/utf-8 x)]
+ [(symbol? x) (symbol->string x)]
+ [(path? x) (path->string x)]
+ [(keyword? x) (keyword->string x)]
+ [(number? x) (number->string x)]
+ [(char? x) (string x)]
+ ;; generic fallback: throw an error
+ [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))
+(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 (splice . contents) (make-special 'splice contents))
(define (verbatim . contents) (make-special 'verbatim contents))
(define (unverbatim . contents) (make-special 'unverbatim contents))
-(define (prefix pfx . contents) (make-special 'prefix (cons pfx contents)))
+(define flush (make-special 'flush #f))
+(define (prefix pfx . contents) (make-special 'prefix (cons pfx contents)))
-(define make-spaces
- (let ([t (make-hasheq)])
+(define make-spaces ; (efficiently)
+ (let ([t (make-hasheq)] [v (make-vector 80 #f)])
(lambda (n)
- (or (hash-ref t n #f)
- (let ([spaces (make-bytes n 32)]) (hash-set! t n spaces) spaces)))))
+ (or (if (< n 80) (vector-ref v n) (hash-ref t n #f))
+ (let ([spaces (make-string n #\space)])
+ (if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces))
+ spaces)))))
