Much improved `wrapped-output'.

collects/tests/xrepl/main.rkt

@@ -1,96 +1,4 @@
 #lang at-exp racket/base
 
-(define verbose? (make-parameter #f))
+(require "xrepl.rkt" "wrapping-output.rkt")
-
+(test-xrepl)
-(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»
-  |=@||}=|

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)

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

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
+;; wrapped output
-(define wrap-prefix (make-parameter ""))
+(define-syntax-rule (wrapped-output body ...)
-(define (wprintf fmt . args)
+  (do-wrapped-output (λ () body ...)))
-  (let ([o    (current-output-port)]
+(define (append-two-spaces s) (string-append s "  "))
-        [wcol (wrap-column)]
+(define (do-wrapped-output thunk [prefix-rx #rx#"^; *"]
-        [pfx  (wrap-prefix)]
+                           [make-soft-prefix append-two-spaces])
-        [strs (regexp-split #rx" +" (apply format fmt args))])
+  (define-values [ip op] (make-pipe))
-    (write-string (car strs) o)
+  (define th (thread (λ () (parameterize ([current-output-port op]) (thunk))
-    (for ([str (in-list (cdr strs))])
+                           (close-output-port op))))
-      (define-values [line col pos] (port-next-location o))
+  (define o    (current-output-port))
-      (if ((+ col (string-length str)) . >= . wcol)
+  (define wcol (wrap-column))
-        (begin (newline o) (write-string pfx o))
+  (let loop ()
-        (write-string " " o))
+    (define prefix (let ([m (regexp-try-match prefix-rx ip)])
-      (write-string str o))))
+                     (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,6 +279,7 @@
     (printf "~a~s" indent (car names))
     (when (pair? (cdr names)) (printf " ~s" (cdr names)))
     (printf ": ~a\n" (command-blurb cmd)))
+  (wrapped-output
     (if cmd
       (begin (show-cmd cmd "; ")
              (printf ";   usage: ,~a" arg)
@@ -265,7 +288,7 @@
              (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)))))
+             (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)])
+    (wrapped-output
       (if (null? syms)
         (printf "; No matches found")
-      (parameterize ([wrap-prefix ";   "])
+        (begin (printf "; Matches: ~s" (car syms))
-        (wprintf "; Matches: ~s" (car syms))
+               (for ([s (in-list (cdr syms))]) (printf ", ~s" s))))
-        (for ([s (in-list (cdr syms))]) (wprintf ", ~s" s))))
+      (printf ".\n"))))
-    (printf ".\n")))
 
 (defcommand (describe desc id) "[<phase-number>] <identifier-or-module> ..."
   "describe a (bound) identifier"
@@ -512,6 +535,7 @@
       (if (and (pair? xs) (number? (syntax-e (car xs))))
         (values #f (syntax-e (car xs)) (cdr xs))
         (values #t 0 xs))))
+  (wrapped-output
     (for ([id/mod (in-list ids/mods)])
       (define dtm (syntax->datum id/mod))
       (define mod
@@ -530,7 +554,7 @@
               [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?))))
+      (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))
+        (printf ";   imports~a: ~a" (phase->name phase "-~a") (car imps))
-          (for ([imp (in-list (cdr imps))]) (wprintf ", ~a" imp))
+        (for ([imp (in-list (cdr imps))]) (printf ", ~a" imp))
-          (wprintf ".\n")))))
+        (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"
+        (printf ";   direct ~a exports~a: ~a"
                 kind (phase->name phase "-~a") (car exps))
-          (for ([exp (in-list (cdr exps))]) (wprintf ", ~a" exp))
+        (for ([exp (in-list (cdr exps))]) (printf ", ~a" exp))
-          (wprintf ".\n")))))
+        (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 msg "[,bt for context]")
-  (define long-msg "[use ,backtrace to display context]")
+  (parameterize ([current-output-port (current-error-port)])
-  (if backtrace?
+    (wrapped-output
-    (let ([short? (and (not (regexp-match? #rx"\n" str))
+      (if backtrace? (printf "; ~a ~a\n" str msg) (printf "; ~a\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)))
 
 ;; ----------------------------------------------------------------------------
 ;; set up the xrepl environment