From c7bf34d38773d5e4c29a45072d57bcc33c98be03 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Tue, 19 Jul 2011 00:36:08 -0400
Subject: [PATCH] Improve macro stepper output, and some more ,stx outputs.
 (cherry picked from commit 8109299ec86be6f2ddc89c2862e5a62b5280dcae)

---
 collects/xrepl/xrepl.rkt | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

diff --git a/collects/xrepl/xrepl.rkt b/collects/xrepl/xrepl.rkt
index 3352cca767..d4b1a4cd33 100644
--- a/collects/xrepl/xrepl.rkt
+++ b/collects/xrepl/xrepl.rkt
@@ -961,7 +961,7 @@
         (namespace-require init)
         (hash-set! namespaces name (cons (current-namespace) init))))
     (when (and name (not (eq? name (current-namespace-name))))
-      (printf "; *** switching to the `~s' namespace ***\n" name)
+      (printf "; *** Switching to the `~s' namespace ***\n" name)
       (let ([x (hash-ref namespaces (current-namespace-name))])
         (unless (eq? (car x) old-namespace)
           (printf "; (note: saving current namespace for `~s')\n"
@@ -1000,6 +1000,19 @@
                       (map (λ (s) (namespace-symbol->identifier (car s)))
                            (cdr (assq 0 stxs)))))))
           (λ (id) (not (ormap (λ (s) (free-identifier=? id s)) base-stxs))))))
+(define (macro-stepper . args)
+  (define-values [i o] (make-pipe))
+  (parameterize ([current-output-port o])
+    (thread (λ () (apply expand/step-text args) (close-output-port o))))
+  (let loop ()
+    (define l (read-line i))
+    (unless (eof-object? l)
+      ;; hack: beautify the stepper's output -- remove empty line, indent code
+      (unless (equal? "" l)
+        (printf (if (regexp-match? #px"^[A-Z][a-z]+\\b" l)
+                  "; ---- ~a ----\n" "; ~a\n")
+                l))
+      (loop))))
 (defcommand (syntax stx st) "[<expr>] [<flag> ...]"
   "set syntax object to inspect, and control it"
   ["With no arguments, will show the previously set (or expanded) syntax"
@@ -1017,22 +1030,22 @@
   (define args (getarg 'syntax 'list))
   (for ([stx (in-list (if (null? args) '(#f) args))])
     (define (show/set label stx)
-      (printf "~a\n" label)
+      (printf "; ~a\n" label)
       (current-syntax stx)
-      (pretty-write (syntax->datum stx)))
+      (display "; ") (pretty-write (syntax->datum stx)))
     (define (cur) (or (current-syntax) (cmderror "no syntax set yet")))
     (case (and stx (if (identifier? stx) (syntax-e stx) '--none--))
-      [(#f) (show/set "current syntax:" (cur))]
+      [(#f) (show/set "Current syntax:" (cur))]
       [(^)  (if (last-input-syntax)
-              (show/set "using last expression:" (last-input-syntax))
+              (show/set "Using last expression:" (last-input-syntax))
               (cmderror "no expression entered yet"))]
       [(+)  (show/set "expand-once ->" (expand-once (cur)))]
       [(!)  (show/set "expand ->" (expand (cur)))]
-      [(*)  (printf "stepper:\n") (expand/step-text (cur) (not-in-base))]
-      [(**) (printf "stepper:\n") (expand/step-text (cur))]
+      [(*)  (printf "; Stepper:\n") (macro-stepper (cur) (not-in-base))]
+      [(**) (printf "; Stepper:\n") (macro-stepper (cur))]
       [else
        (if (syntax? stx)
-         (begin (printf "syntax set\n") (current-syntax stx))
+         (begin (printf "; Syntax set\n") (current-syntax stx))
          (cmderror "internal error: ~s ~s" stx (syntax? stx)))])))
 
 ;; ----------------------------------------------------------------------------