From d1f1c4011d8cf045d990bfe045c9a9bf2be635df Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 02:27:12 +0000 Subject: [PATCH] A complete rewrite of text output using port state now. Also a few more text-controlling primitives. svn: r14065 original commit: ca30b05114115470136c32dc8a2fca34e6ceb1d8 --- collects/scribble/text/output.ss | 235 ++++++++++++++++++++----------- 1 file changed, 154 insertions(+), 81 deletions(-) diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss index 808eb625..f0e5e80d 100644 --- 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)))))