suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Much improved `wrapped-output'.

Browse Source
This commit is contained in:
Eli Barzilay 2011-08-01 06:21:38 -04:00
parent 3f40742968
commit e52e7defae
4 changed files with 281 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
collects/tests/xrepl/main.rkt
View File

@ -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)

67
collects/tests/xrepl/wrapping-output.rkt Normal file
View File

@ -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)

125
collects/tests/xrepl/xrepl.rkt Normal file
View File

@ -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»
|=@||}=|)

157
collects/xrepl/xrepl.rkt
View File

@ -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<? #:key cdr)]
[syms (map car syms)])
(if (null? syms)
(printf "; No matches found")
(parameterize ([wrap-prefix "; "])
(wprintf "; Matches: ~s" (car syms))
(for ([s (in-list (cdr syms))]) (wprintf ", ~s" s))))
(printf ".\n")))
(wrapped-output
(if (null? syms)
(printf "; No matches found")
(begin (printf "; Matches: ~s" (car syms))
(for ([s (in-list (cdr syms))]) (printf ", ~s" s))))
(printf ".\n"))))
(defcommand (describe desc id) "[<phase-number>] <identifier-or-module> ..."
"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