From e52e7defaea1323f6be1ca14e6b838dfdd96aaba Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 1 Aug 2011 06:21:38 -0400 Subject: [PATCH] Much improved `wrapped-output'. --- collects/tests/xrepl/main.rkt | 96 +------------- collects/tests/xrepl/wrapping-output.rkt | 67 ++++++++++ collects/tests/xrepl/xrepl.rkt | 125 ++++++++++++++++++ collects/xrepl/xrepl.rkt | 157 +++++++++++++---------- 4 files changed, 281 insertions(+), 164 deletions(-) create mode 100644 collects/tests/xrepl/wrapping-output.rkt create mode 100644 collects/tests/xrepl/xrepl.rkt diff --git a/collects/tests/xrepl/main.rkt b/collects/tests/xrepl/main.rkt index 82155526e9..10daa27615 100644 --- a/collects/tests/xrepl/main.rkt +++ b/collects/tests/xrepl/main.rkt @@ -1,96 +1,4 @@ #lang at-exp racket/base -(define verbose? (make-parameter #f)) - -(define global-ns (current-namespace)) - -(define stderr (current-error-port)) - -(define (test-xrepl . args) - (define show-all? (verbose?)) - (define-values [Ii Io] (make-pipe)) - (define-values [Oi Oo] (make-pipe)) - (define repl-thread - (parameterize ([current-input-port Ii] - [current-output-port Oo] - [current-error-port Oo] - [current-namespace (make-empty-namespace)] - [exit-handler (λ (_) (kill-thread repl-thread))]) - (thread (λ () - (namespace-attach-module global-ns 'racket/base) - (namespace-require 'racket) - (dynamic-require 'xrepl #f) - (read-eval-print-loop))))) - (define (repl-> expected) - (define output (read-string (string-length expected) Oi)) - (if (equal? output expected) - (when show-all? (display output)) - (error 'xrepl "test failure, expected ~s, got ~s" expected output))) - (let loop ([strs args] [input? #f]) - (cond - [(and (pair? strs) (equal? "" (car strs))) - (loop (cdr strs) input?)] - [(and (thread-dead? repl-thread) (null? strs)) - (printf "All tests passed.\n")] - [(thread-dead? repl-thread) - (error 'xrepl "test failure, repl thread died unexpectedly")] - [(null? strs) - (if (sync/timeout 1 repl-thread) - (loop strs input?) - (error 'xrepl "test failure, repl thread is alive at end of tests"))] - [(eq? '« (car strs)) - (when input? (error 'xrepl "bad test: unterminated `«'")) - (loop (cdr strs) #t)] - [(eq? '» (car strs)) - (unless input? (error 'xrepl "bad test: redundant `»'")) - (loop (cdr strs) 'newline)] - [(regexp-match #rx"^(.*?)(?: *⇒[^\n]*)(.*)" (car strs)) - => (λ (m) (loop (list* (cadr m) (caddr m) (cdr strs)) input?))] - [(regexp-match #rx"^(.*?)([«»])(.*)" (car strs)) - => (λ (m) (loop (list* (cadr m) (string->symbol (caddr m)) (cadddr m) - (cdr strs)) - input?))] - [(eq? 'newline input?) - (unless (regexp-match? #rx"^\n" (car strs)) - (error 'xrepl "bad test: `»' followed by a non-newline")) - (newline Io) (flush-output Io) - (when show-all? (newline) (flush-output)) - (loop (cons (substring (car strs) 1) (cdr strs)) #f)] - [input? - (display (car strs) Io) - (when show-all? (display (car strs)) (flush-output)) - (loop (cdr strs) #t)] - [else - (repl-> (car strs)) - (loop (cdr strs) #f)]))) - -@test-xrepl|={ - -> «(- 2 1)» - 1 - -> «(values 2 3)» - 2 - 3 - -> «(values 4)» - 4 - -> «(list ^ ^^ ^^^ ^^^^)» - '(4 3 2 1) - -> «(module foo racket (define x 123))» - -> «,en foo» - 'foo> «x» - 123 - 'foo> «,top» - -> «(define enter! 123)» - -> «(enter! 'foo)» - procedure application: expected procedure, given: 123; arguments were: 'foo - [use ,backtrace to display context] - -> «,en foo» ⇒ but this still works - 'foo> «,top» - -> «,switch foo» - ; *** Initializing a new `foo' namespace with "racket/main.rkt" *** - ; *** Switching to the `foo' namespace *** - foo::-> «,switch *» - ; *** Switching to the `*' namespace *** - -> «bleh» - reference to undefined identifier: bleh [,bt for context] - -> «,ex» - |=@||}=| +(require "xrepl.rkt" "wrapping-output.rkt") +(test-xrepl) diff --git a/collects/tests/xrepl/wrapping-output.rkt b/collects/tests/xrepl/wrapping-output.rkt new file mode 100644 index 0000000000..eaaec34ca5 --- /dev/null +++ b/collects/tests/xrepl/wrapping-output.rkt @@ -0,0 +1,67 @@ +#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") + +(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) diff --git a/collects/tests/xrepl/xrepl.rkt b/collects/tests/xrepl/xrepl.rkt new file mode 100644 index 0000000000..5128c30761 --- /dev/null +++ b/collects/tests/xrepl/xrepl.rkt @@ -0,0 +1,125 @@ +#lang at-exp racket/base + +(define verbose? (make-parameter #f)) + +(define global-ns (current-namespace)) + +(define stderr (current-error-port)) + +(define ((make-xrepl-test . args)) + (define show-all? (verbose?)) + (define-values [Ii Io] (make-pipe)) + (define-values [Oi Oo] (make-pipe)) + (define repl-thread + (parameterize ([current-input-port Ii] + [current-output-port Oo] + [current-error-port Oo] + [current-namespace (make-empty-namespace)] + [exit-handler (λ (_) (kill-thread repl-thread))]) + (thread (λ () + (namespace-attach-module global-ns 'racket/base) + (namespace-require 'racket/init) + (dynamic-require 'xrepl #f) + (parameterize ([current-namespace + (module->namespace 'xrepl/xrepl)]) + ((namespace-variable-value 'wrap-column) 77)) + (read-eval-print-loop))))) + (define (repl-> expected) + (define output (read-string (string-length expected) Oi)) + (if (equal? output expected) + (when show-all? (display output)) + (error 'xrepl "test failure at interaction #~a, expected ~s, got ~s" + tests-num expected output))) + (define tests-num 0) + (let loop ([strs args] [input? #f]) + (cond + [(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)] + [(thread-dead? repl-thread) + (error 'xrepl "test failure, repl thread died unexpectedly")] + [(null? strs) + (if (sync/timeout 1 repl-thread) + (loop strs input?) + (error 'xrepl "test failure, repl thread is alive at end of tests"))] + [(eq? '« (car strs)) + (when input? (error 'xrepl "bad test: unterminated `«'")) + (set! tests-num (add1 tests-num)) + (loop (cdr strs) #t)] + [(eq? '» (car strs)) + (unless input? (error 'xrepl "bad test: redundant `»'")) + (loop (cdr strs) 'newline)] + [(regexp-match #rx"^(.*?)(?: *⇒[^\n]*)(.*)" (car strs)) + => (λ (m) (loop (list* (cadr m) (caddr m) (cdr strs)) input?))] + [(regexp-match #rx"^(.*?)([«»])(.*)" (car strs)) + => (λ (m) (loop (list* (cadr m) (string->symbol (caddr m)) (cadddr m) + (cdr strs)) + input?))] + [(eq? 'newline input?) + (unless (regexp-match? #rx"^\n" (car strs)) + (error 'xrepl "bad test: `»' followed by a non-newline")) + (newline Io) (flush-output Io) + (when show-all? (newline) (flush-output)) + (loop (cons (substring (car strs) 1) (cdr strs)) #f)] + [input? + (display (car strs) Io) + (when show-all? (display (car strs)) (flush-output)) + (loop (cdr strs) #t)] + [else + (repl-> (car strs)) + (loop (cdr strs) #f)]))) + +(provide test-xrepl) +(define test-xrepl @make-xrepl-test|={ + -> «(- 2 1)» + 1 + -> «(values 2 3)» + 2 + 3 + -> «(values 4)» + 4 + -> «(list ^ ^^ ^^^ ^^^^)» + '(4 3 2 1) + -> «(module foo racket (define x 123))» + -> «,en foo» + 'foo> «x» + 123 + 'foo> «,top» + -> «(define enter! 123)» + -> «(enter! 'foo)» + ; procedure application: expected procedure, given: 123; arguments were: 'foo + ; [,bt for context] + -> «(enter! 'fooo)» + ; procedure application: expected procedure, given: 123; arguments were: + ; 'fooo [,bt for context] + -> «,en foo» ⇒ but this still works + 'foo> «,top» + -> «,switch foo» + ; *** Initializing a new `foo' namespace with "racket/init.rkt" *** + ; *** Switching to the `foo' namespace *** + foo::-> «,switch *» + ; *** Switching to the `*' namespace *** + -> «bleh» + ; reference to undefined identifier: bleh [,bt for context] + -> «,ap BLEH» + ; No matches found. + -> «,ap path->» + ; Matches: path->bytes, path->complete-path, path->directory-path, + ; path->string, some-system-path->string. + -> «,desc cons» + ; `cons' is a bound identifier, + ; defined in #%kernel + ; required through "racket/init.rkt" + -> «,desc lambda» + ; `lambda' is a bound identifier, + ; defined in racket/private/kw.rkt as `new-lambda' + ; required through "racket/init.rkt" + -> «,desc racket/runtime-path» + ; `racket/runtime-path' is a module, + ; located at racket/runtime-path.rkt + ; imports: mzlib/runtime-path.rkt, racket/base.rkt. + ; imports-for-syntax: racket/base.rkt. + ; direct syntax exports: define-runtime-module-path. + -> «,ex» + |=@||}=|) diff --git a/collects/xrepl/xrepl.rkt b/collects/xrepl/xrepl.rkt index ca72e71d55..670a706c89 100644 --- a/collects/xrepl/xrepl.rkt +++ b/collects/xrepl/xrepl.rkt @@ -113,20 +113,42 @@ (define-values [line col pos] (port-next-location last-output-port)) (set-port-next-location! last-output-port line 0 pos)) -;; wrapped `printf' (cheap but effective), aware of the visual col -(define wrap-prefix (make-parameter "")) -(define (wprintf fmt . args) - (let ([o (current-output-port)] - [wcol (wrap-column)] - [pfx (wrap-prefix)] - [strs (regexp-split #rx" +" (apply format fmt args))]) - (write-string (car strs) o) - (for ([str (in-list (cdr strs))]) - (define-values [line col pos] (port-next-location o)) - (if ((+ col (string-length str)) . >= . wcol) - (begin (newline o) (write-string pfx o)) - (write-string " " o)) - (write-string str o)))) +;; 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-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 ;; ---------------------------------------------------------------------------- ;; toplevel "," commands management @@ -257,15 +279,16 @@ (printf "~a~s" indent (car names)) (when (pair? (cdr names)) (printf " ~s" (cdr names))) (printf ": ~a\n" (command-blurb cmd))) - (if cmd - (begin (show-cmd cmd "; ") - (printf "; usage: ,~a" arg) - (let ([a (command-argline cmd)]) (when a (printf " ~a" a))) - (printf "\n") - (for ([d (in-list (command-desc cmd))]) - (printf "; ~a\n" d))) - (begin (printf "; Available commands:\n") - (for-each (λ (c) (show-cmd c "; ")) (reverse commands-list))))) + (wrapped-output + (if cmd + (begin (show-cmd cmd "; ") + (printf "; usage: ,~a" arg) + (let ([a (command-argline cmd)]) (when a (printf " ~a" a))) + (printf "\n") + (for ([d (in-list (command-desc cmd))]) + (printf "; ~a\n" d))) + (begin (printf "; Available commands:\n") + (for-each (λ (c) (show-cmd c "; ")) (reverse commands-list)))))) ;; ---------------------------------------------------------------------------- ;; generic commands @@ -494,12 +517,12 @@ [syms (if look (filter (λ (s) (look (cdr s))) syms) syms)] [syms (sort syms string] ..." "describe a (bound) identifier" @@ -512,25 +535,26 @@ (if (and (pair? xs) (number? (syntax-e (car xs)))) (values #f (syntax-e (car xs)) (cdr xs)) (values #t 0 xs)))) - (for ([id/mod (in-list ids/mods)]) - (define dtm (syntax->datum id/mod)) - (define mod - (and try-mods? - (match dtm - [(list 'quote (and sym (? module-name?))) sym] - [(? module-name?) dtm] - [_ (let ([x (with-handlers ([exn:fail? (λ (_) #f)]) - (modspec->path dtm))]) - (cond [(or (not x) (path? x)) x] - [(symbol? x) (and (module-name? x) `',x)] - [else (error 'describe "internal error: ~s" x)]))]))) - (define bind - (cond [(identifier? id/mod) (identifier-binding id/mod level)] - [mod #f] - [else (cmderror "not an identifier or a known module: ~s" dtm)])) - (define bind? (or bind (not mod))) - (when bind? (describe-binding dtm bind level)) - (when mod (describe-module dtm mod bind?)))) + (wrapped-output + (for ([id/mod (in-list ids/mods)]) + (define dtm (syntax->datum id/mod)) + (define mod + (and try-mods? + (match dtm + [(list 'quote (and sym (? module-name?))) sym] + [(? module-name?) dtm] + [_ (let ([x (with-handlers ([exn:fail? (λ (_) #f)]) + (modspec->path dtm))]) + (cond [(or (not x) (path? x)) x] + [(symbol? x) (and (module-name? x) `',x)] + [else (error 'describe "internal error: ~s" x)]))]))) + (define bind + (cond [(identifier? id/mod) (identifier-binding id/mod level)] + [mod #f] + [else (cmderror "not an identifier or a known module: ~s" dtm)])) + (define bind? (or bind (not mod))) + (when bind? (describe-binding dtm bind level)) + (when mod (describe-module dtm mod bind?))))) (define (describe-binding sym b level) (define at-phase (phase->name level " (~a)")) (cond @@ -604,20 +628,18 @@ relname)) (if (null? imports) (printf "; no imports.\n") - (parameterize ([wrap-prefix "; "]) - (for ([imps (in-list imports)]) - (let ([phase (car imps)] [imps (cdr imps)]) - (wprintf "; imports~a: ~a" (phase->name phase "-~a") (car imps)) - (for ([imp (in-list (cdr imps))]) (wprintf ", ~a" imp)) - (wprintf ".\n"))))) + (for ([imps (in-list imports)]) + (let ([phase (car imps)] [imps (cdr imps)]) + (printf "; imports~a: ~a" (phase->name phase "-~a") (car imps)) + (for ([imp (in-list (cdr imps))]) (printf ", ~a" imp)) + (printf ".\n")))) (define (show-exports exports kind) - (parameterize ([wrap-prefix "; "]) - (for ([exps (in-list exports)]) - (let ([phase (car exps)] [exps (cdr exps)]) - (wprintf "; direct ~a exports~a: ~a" - kind (phase->name phase "-~a") (car exps)) - (for ([exp (in-list (cdr exps))]) (wprintf ", ~a" exp)) - (wprintf ".\n"))))) + (for ([exps (in-list exports)]) + (let ([phase (car exps)] [exps (cdr exps)]) + (printf "; direct ~a exports~a: ~a" + kind (phase->name phase "-~a") (car exps)) + (for ([exp (in-list (cdr exps))]) (printf ", ~a" exp)) + (printf ".\n")))) (if (and (null? val-exports) (null? stx-exports)) (printf "; no direct exports.\n") (begin (show-exports val-exports "value") @@ -1353,15 +1375,10 @@ [s (regexp-replace* #rx"\n\n+" s "\n")]) (and (not (equal? str s)) (begin (set! last-backtrace s) #t))))) - (define short-msg "[,bt for context]") - (define long-msg "[use ,backtrace to display context]") - (if backtrace? - (let ([short? (and (not (regexp-match? #rx"\n" str)) - (<= (+ (string-length str) 1 (string-length short-msg)) - (wrap-column)))]) - (eprintf (if short? "~a ~a\n" "~a\n~a\n") - str (if short? short-msg long-msg))) - (eprintf "~a\n" str))) + (define msg "[,bt for context]") + (parameterize ([current-output-port (current-error-port)]) + (wrapped-output + (if backtrace? (printf "; ~a ~a\n" str msg) (printf "; ~a\n" str))))) ;; ---------------------------------------------------------------------------- ;; set up the xrepl environment