Use `scribble/text/wrap' in xrepl.

(Also organize the tests a little.)

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)
+(require "xrepl.rkt" "wrapped-output.rkt" "known-module.rkt" tests/eli-tester)
-(test do (test-wrapping-output)
+(test do (test-wrapped-output)
       do (test-known-module)
       do (test-xrepl))

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

collects/tests/xrepl/wrapping-output.rkt

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

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)

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 ...)
+(define-syntax-rule (with-wrapped-output body ...)
-  (do-wrapped-output (λ () body ...)))
+  (do-xrepl-wrapped-output (λ () body ...)))
-(define (append-two-spaces s) (string-append s "  "))
+(define (do-xrepl-wrapped-output thunk)
-(define (do-wrapped-output thunk [prefix-rx #rx#"^; *"]
+  (do-wrapped-output thunk #:indent-first -2 #:line-prefix #rx"^;+ *"))
-                           [make-soft-prefix append-two-spaces])
+;; 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))
+  (define widths
-                           (close-output-port op))))
+    (cond [(fst-indent . > . 0) (cons (- width fst-indent) width)]
-  (define o    (current-output-port))
+          [(fst-indent . < . 0) (cons width (+ width fst-indent))]
-  (define wcol (wrap-column))
+          [else (cons width width)]))
-  (let loop ()
+  (define indents
-    (define prefix (let ([m (regexp-try-match prefix-rx ip)])
+    (let ([spaces (make-bytes (abs fst-indent) (char->integer #\space))])
-                     (if m (bytes->string/utf-8 (car m)) "")))
+      (cond [(fst-indent . > . 0) (cons spaces #"")]
-    (write-string prefix o)
+            [(fst-indent . < . 0) (cons #"" spaces)]
-    (define soft-prefix #f)
+            [else (cons #"" #"")])))
-    (define (soft-newline)
+  (define out (current-output-port))
-      (unless soft-prefix (set! soft-prefix (make-soft-prefix prefix)))
+  (define (wrapper)
-      (newline) (write-string soft-prefix o) (string-length soft-prefix))
+    (define m (cond [(regexp-match #rx#"^(?:\n|[^\n]+)" ip) => car] [else #f]))
-    (let line-loop ([col (string-length prefix)])
+    (when m ; #f => we're at the end
-      (define m (regexp-match #rx#"^( +)?(\n|[^ \n]+)" ip))
+      (if (equal? #"\n" m)
-      (when m ; #f => at end
+        (newline out)
-        (define spaces (and (cadr m) (bytes->string/utf-8 (cadr m))))
+        (let* ([i (cdar (regexp-match-positions #rx#"^ *" m))]
-        (define str (bytes->string/utf-8 (caddr m)))
+               [p (regexp-match-positions prefix-rx m i)]
-        (if (equal? "\n" str)
+               [i (if (and p (= (caar p) i)) (cdar p) i)]
-          (begin (newline o) (loop))
+               [j (caar (regexp-match-positions #rx" *$" m))]
-          (let* ([strlen (string-length str)]
+               [widths (cons (- (car widths) i) (- (cdr widths) i))]
-                 [spclen (if spaces (string-length spaces) 0)]
+               [lines  (wrap-line (bytes->string/utf-8 (subbytes m i j))
-                 [nextcol (+ col strlen spclen)])
+                                  widths split-word)])
-            (line-loop
+          (write-bytes m out 0 i)
-             (if (nextcol . > . wcol)
+          (write-bytes (car indents) out)
-               (let ([col (soft-newline)]) (write-string str o) (+ col strlen))
+          (write-string (car lines) out)
-               (begin (when spaces (write-string spaces o))
+          (for ([l (in-list (cdr lines))])
-                      (write-string str o) nextcol)))))))
+            (newline out)
-    (unless (eof-object? (peek-char ip)) (loop)))
+            (write-bytes m out 0 i)
-  (thread-wait th)) ; just in case
+            (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 string<? #:key cdr)]
          [syms (map car syms)])
-    (wrapped-output
+    (with-wrapped-output
       (if (null? syms)
         (printf "; No matches found")
         (begin (printf "; Matches: ~s" (car syms))
@@ -594,7 +604,7 @@
       (if (and (pair? xs) (number? (syntax-e (car xs))))
         (values #f (syntax-e (car xs)) (cdr xs))
         (values #t 0 xs))))
-  (wrapped-output
+  (with-wrapped-output
     (for ([id/mod (in-list ids/mods)])
       (define dtm (syntax->datum 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
+  (with-wrapped-output
-   (for ([decision (in-list '(keep bypass drop))])
+    (for ([decision (in-list '(keep bypass drop))])
-     (define all (filter (λ (x) (eq? decision (car x))) rs))
+      (define all (filter (λ (x) (eq? decision (car x))) rs))
-     (unless (null? all)
+      (unless (null? all)
-       (define names (map cadr all))
+        (define names (map cadr all))
-       ;; doesn't print the phase number (third element of all members)
+        ;; doesn't print the phase number (third element of all members)
-       (printf "; ~a: ~a"
+        (printf "; ~a: ~a"
-               (string-titlecase (symbol->string decision)) (car names))
+                (string-titlecase (symbol->string decision)) (car names))
-       (for ([n (in-list (cdr names))]) (printf ", ~a" n))
+        (for ([n (in-list (cdr names))]) (printf ", ~a" n))
-       (printf ".\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)))))
 
 ;; ----------------------------------------------------------------------------