diff --git a/collects/tests/xrepl/main.rkt b/collects/tests/xrepl/main.rkt index 40b373297f..f67e9450a1 100644 --- a/collects/tests/xrepl/main.rkt +++ b/collects/tests/xrepl/main.rkt @@ -1,6 +1,6 @@ #lang at-exp racket/base -(require "xrepl.rkt" "wrapping-output.rkt" "known-module.rkt" tests/eli-tester) -(test do (test-wrapping-output) +(require "xrepl.rkt" "wrapped-output.rkt" "known-module.rkt" tests/eli-tester) +(test do (test-wrapped-output) do (test-known-module) do (test-xrepl)) diff --git a/collects/tests/xrepl/wrapped-output.rkt b/collects/tests/xrepl/wrapped-output.rkt new file mode 100644 index 0000000000..d04dcb7744 --- /dev/null +++ b/collects/tests/xrepl/wrapped-output.rkt @@ -0,0 +1,41 @@ +#lang at-exp racket/base + +(require tests/eli-tester xrepl/xrepl racket/string) +(define-values [do-xrepl-wrapped-output wrap-width] + (parameterize ([current-namespace (module->namespace 'xrepl/xrepl)]) + (apply values (map namespace-variable-value + '(do-xrepl-wrapped-output wrap-width))))) + +(define (wrap . text) + (parameterize ([wrap-width 12] + [current-output-port (open-output-string)]) + ;; use "#"s in the input to avoid messing up highlighting in emacs + (do-xrepl-wrapped-output + (λ () (display (regexp-replace* #rx"#" (string-append* text) ";")))) + (regexp-replace* #rx";" (get-output-string (current-output-port)) "#"))) + +(provide test-wrapped-output) +(module+ main (test-wrapped-output)) +(define (test-wrapped-output) + (define n "\n") + (define s string-append) + (define w wrap) + (test @w{blah} => @s{blah} + @w{blah@n} => @s{blah@n} + @w{#blah} => @s{#blah} + @w{#blah@n} => @s{#blah@n} + @w{#blah @n} => @s{#blah@n} + @w{# blah@n} => @s{# blah@n} + @w{# blah @n} => @s{# blah@n} + @w{#blah@|n|#blah@n} + => @s{#blah@|n|#blah@n} + @w{#ab cd ef gh ij kl mn op qr st} + => @s{#ab cd ef gh@|n|# ij kl mn@|n|# op qr st} + @w{#ab cd ef gh ij kl mn op qr st@n} + => @s{#ab cd ef gh@|n|# ij kl mn@|n|# op qr st@n} + @w{#ab@|n|#cd ef gh ij kl mn op qr st@n} + => @s{#ab@|n|#cd ef gh ij@|n|# kl mn op@|n|# qr st@n} + @w{# ab@|n|# cd ef gh ij kl mn op qr st@n} + => @s{# ab@|n|# cd ef gh@|n|# ij kl@|n|# mn op@|n|# qr st@n} + @w{# ab@|n|# cd ef gh ij kl mn op qr st@n} + => @s{# ab@|n|# cd ef gh@|n|# ij kl mn@|n|# op qr@|n|# st@n})) diff --git a/collects/tests/xrepl/wrapping-output.rkt b/collects/tests/xrepl/wrapping-output.rkt deleted file mode 100644 index 7798a8f840..0000000000 --- a/collects/tests/xrepl/wrapping-output.rkt +++ /dev/null @@ -1,70 +0,0 @@ -#lang at-exp racket/base - -(require xrepl/xrepl) -(define-values [do-wrapped-output wrap-column] - (parameterize ([current-namespace (module->namespace 'xrepl/xrepl)]) - (apply values (map namespace-variable-value - '(do-wrapped-output wrap-column))))) - -(define test-num 0) - -(define (test to-wrap expected) - (parameterize ([current-output-port (open-output-string)]) - (do-wrapped-output (λ () (display to-wrap)) #rx#"^# *") - (define result (get-output-string (current-output-port))) - (set! test-num (add1 test-num)) - (unless (equal? result expected) - (error - 'test-wrapped-output - (string-append "test failure in test #~a\n----input----\n~a\n" - "----expected----\n~a\n----received----\n~a\n----") - test-num to-wrap expected result)))) - -(define s string-append) -(define n "\n") - -(provide test-wrapping-output) -(module+ main (test-wrapping-output)) -(define (test-wrapping-output) - (wrap-column 12) - (test @s{blah} @s{blah}) - (test @s{blah@n} @s{blah@n}) - (test @s{#blah} @s{#blah}) - (test @s{#blah@n} @s{#blah@n}) - (test @s{#blah @n} @s{#blah@n}) - (test @s{# blah@n} @s{# blah@n}) - (test @s{# blah @n} @s{# blah@n}) - (test @s{#blah - #blah@n} - @s{#blah - #blah@n}) - (test @s{#ab cd ef gh ij kl mn op qr st} - @s{#ab cd ef gh - # ij kl mn - # op qr st}) - (test @s{#ab cd ef gh ij kl mn op qr st@n} - @s{#ab cd ef gh - # ij kl mn - # op qr st@n}) - (test @s{#ab - #cd ef gh ij kl mn op qr st@n} - @s{#ab - #cd ef gh ij - # kl mn op - # qr st@n}) - (test @s{# ab - # cd ef gh ij kl mn op qr st@n} - @s{# ab - # cd ef gh - # ij kl - # mn op - # qr st@n}) - (test @s{# ab - # cd ef gh ij kl mn op qr st@n} - @s{# ab - # cd ef gh - # ij kl mn - # op qr - # st@n}) - (printf "~a wrapped output tests passed\n" test-num) - #t) diff --git a/collects/tests/xrepl/xrepl.rkt b/collects/tests/xrepl/xrepl.rkt index 08e85258e2..a9e6e92b68 100644 --- a/collects/tests/xrepl/xrepl.rkt +++ b/collects/tests/xrepl/xrepl.rkt @@ -22,7 +22,7 @@ (dynamic-require 'xrepl #f) (parameterize ([current-namespace (module->namespace 'xrepl/xrepl)]) - ((namespace-variable-value 'wrap-column) 77)) + ((namespace-variable-value 'wrap-width) 77)) (read-eval-print-loop))))) (define (repl-> expected) (define output (read-string (string-length expected) Oi)) @@ -36,7 +36,7 @@ [(and (pair? strs) (equal? "" (car strs))) (loop (cdr strs) input?)] [(and (thread-dead? repl-thread) (null? strs)) - (printf "~a interaction tests passed.\n" tests-num)] + (printf "~a interaction tests passed\n" tests-num)] [(thread-dead? repl-thread) (error 'xrepl "test failure, repl thread died unexpectedly")] [(null? strs) diff --git a/collects/xrepl/xrepl.rkt b/collects/xrepl/xrepl.rkt index ece0e52e66..bf9fc09155 100644 --- a/collects/xrepl/xrepl.rkt +++ b/collects/xrepl/xrepl.rkt @@ -6,12 +6,11 @@ (define toplevel-prefix (make-parameter "-")) ; when not in a module (define saved-values-number (make-parameter 5)) (define saved-values-patterns (make-parameter '("^" "$~a"))) -(define wrap-column (make-parameter 79)) ;; TODO: when there's a few more of these, make them come from the prefs ;; ---------------------------------------------------------------------------- -(require racket/list racket/match) +(require racket/list racket/match scribble/text/wrap) ;; ---------------------------------------------------------------------------- ;; utilities @@ -165,41 +164,52 @@ (set-port-next-location! last-output-port line 0 pos)) ;; wrapped output -(define-syntax-rule (wrapped-output body ...) - (do-wrapped-output (λ () body ...))) -(define (append-two-spaces s) (string-append s " ")) -(define (do-wrapped-output thunk [prefix-rx #rx#"^; *"] - [make-soft-prefix append-two-spaces]) +(define-syntax-rule (with-wrapped-output body ...) + (do-xrepl-wrapped-output (λ () body ...))) +(define (do-xrepl-wrapped-output thunk) + (do-wrapped-output thunk #:indent-first -2 #:line-prefix #rx"^;+ *")) +;; maybe move this into scribble/text/wrap +(define (do-wrapped-output thunk + #:wrap-width [width (wrap-width)] + #:line-prefix [prefix-rx #f] ; not including spaces + #:indent-first [fst-indent 0] ; can be negative + #:split-word [split-word #f]) (define-values [ip op] (make-pipe)) - (define th (thread (λ () (parameterize ([current-output-port op]) (thunk)) - (close-output-port op)))) - (define o (current-output-port)) - (define wcol (wrap-column)) - (let loop () - (define prefix (let ([m (regexp-try-match prefix-rx ip)]) - (if m (bytes->string/utf-8 (car m)) ""))) - (write-string prefix o) - (define soft-prefix #f) - (define (soft-newline) - (unless soft-prefix (set! soft-prefix (make-soft-prefix prefix))) - (newline) (write-string soft-prefix o) (string-length soft-prefix)) - (let line-loop ([col (string-length prefix)]) - (define m (regexp-match #rx#"^( +)?(\n|[^ \n]+)" ip)) - (when m ; #f => at end - (define spaces (and (cadr m) (bytes->string/utf-8 (cadr m)))) - (define str (bytes->string/utf-8 (caddr m))) - (if (equal? "\n" str) - (begin (newline o) (loop)) - (let* ([strlen (string-length str)] - [spclen (if spaces (string-length spaces) 0)] - [nextcol (+ col strlen spclen)]) - (line-loop - (if (nextcol . > . wcol) - (let ([col (soft-newline)]) (write-string str o) (+ col strlen)) - (begin (when spaces (write-string spaces o)) - (write-string str o) nextcol))))))) - (unless (eof-object? (peek-char ip)) (loop))) - (thread-wait th)) ; just in case + (define widths + (cond [(fst-indent . > . 0) (cons (- width fst-indent) width)] + [(fst-indent . < . 0) (cons width (+ width fst-indent))] + [else (cons width width)])) + (define indents + (let ([spaces (make-bytes (abs fst-indent) (char->integer #\space))]) + (cond [(fst-indent . > . 0) (cons spaces #"")] + [(fst-indent . < . 0) (cons #"" spaces)] + [else (cons #"" #"")]))) + (define out (current-output-port)) + (define (wrapper) + (define m (cond [(regexp-match #rx#"^(?:\n|[^\n]+)" ip) => car] [else #f])) + (when m ; #f => we're at the end + (if (equal? #"\n" m) + (newline out) + (let* ([i (cdar (regexp-match-positions #rx#"^ *" m))] + [p (regexp-match-positions prefix-rx m i)] + [i (if (and p (= (caar p) i)) (cdar p) i)] + [j (caar (regexp-match-positions #rx" *$" m))] + [widths (cons (- (car widths) i) (- (cdr widths) i))] + [lines (wrap-line (bytes->string/utf-8 (subbytes m i j)) + widths split-word)]) + (write-bytes m out 0 i) + (write-bytes (car indents) out) + (write-string (car lines) out) + (for ([l (in-list (cdr lines))]) + (newline out) + (write-bytes m out 0 i) + (write-bytes (cdr indents) out) + (write-string l out)))) + (wrapper))) + (define th (thread wrapper)) + (parameterize ([current-output-port op]) (thunk)) + (close-output-port op) + (thread-wait th)) ;; ---------------------------------------------------------------------------- ;; toplevel "," commands management @@ -337,7 +347,7 @@ (printf "~a~s" indent (car names)) (when (pair? (cdr names)) (printf " ~s" (cdr names))) (printf ": ~a\n" (command-blurb cmd))) - (wrapped-output + (with-wrapped-output (if cmd (begin (show-cmd cmd "; ") (printf "; usage: ,~a" arg) @@ -576,7 +586,7 @@ [syms (if look (filter (λ (s) (look (cdr s))) syms) syms)] [syms (sort syms stringdatum id/mod)) (define mod (and try-mods? (known-module dtm 'path/sym))) @@ -1136,16 +1146,16 @@ "information."] (define mod (getarg 'module #:default here-mod-or-eof)) (define rs (show-requires mod)) - (wrapped-output - (for ([decision (in-list '(keep bypass drop))]) - (define all (filter (λ (x) (eq? decision (car x))) rs)) - (unless (null? all) - (define names (map cadr all)) - ;; doesn't print the phase number (third element of all members) - (printf "; ~a: ~a" - (string-titlecase (symbol->string decision)) (car names)) - (for ([n (in-list (cdr names))]) (printf ", ~a" n)) - (printf ".\n"))))) + (with-wrapped-output + (for ([decision (in-list '(keep bypass drop))]) + (define all (filter (λ (x) (eq? decision (car x))) rs)) + (unless (null? all) + (define names (map cadr all)) + ;; doesn't print the phase number (third element of all members) + (printf "; ~a: ~a" + (string-titlecase (symbol->string decision)) (car names)) + (for ([n (in-list (cdr names))]) (printf ", ~a" n)) + (printf ".\n"))))) ;; ---------------------------------------------------------------------------- ;; dynamic log output control @@ -1452,7 +1462,7 @@ (begin (set! last-backtrace s) #t))))) (define msg "[,bt for context]") (parameterize ([current-output-port (current-error-port)]) - (wrapped-output + (with-wrapped-output (if backtrace? (printf "; ~a ~a\n" str msg) (printf "; ~a\n" str))))) ;; ----------------------------------------------------------------------------