From d14b6d12d28f6f8f4a81d0b21c6a07d8f22d45c8 Mon Sep 17 00:00:00 2001
From: John Clements <clements@racket-lang.org>
Date: Thu, 1 May 2008 23:49:55 +0000
Subject: [PATCH] ...

svn: r9580
---
 collects/stepper/internal-docs.txt      |  5 +++++
 collects/stepper/private/reconstruct.ss |  7 +++----
 collects/stepper/private/shared.ss      | 13 ++++++++++++-
 3 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt
index 0100e3b2fa..bccbad2612 100644
--- a/collects/stepper/internal-docs.txt
+++ b/collects/stepper/internal-docs.txt
@@ -234,6 +234,11 @@ stepper-args-of-call [ADDED BY RECONSTRUCTOR] :
   this reconstructed (...) expression is the result of a call with these args.
   used by the check-expect unwinder to figure out the expected values.
 
+stepper-hide-completed : don't show the final top-level expression binding
+  for this identifier.
+
+stepper-hide-reduction : don't show the reduction for this term.
+
 STEPPER-HINT COLLISIONS
 
  The major concern with the stepper-hint is that two of them may
diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss
index 413491fbcf..fdf1bc5569 100644
--- a/collects/stepper/private/reconstruct.ss
+++ b/collects/stepper/private/reconstruct.ss
@@ -150,7 +150,7 @@
       [(result-value-break)
        (and (pair? mark-list)
             (let ([expr (mark-source (car mark-list))])
-              (equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect)))]
+              (stepper-syntax-property expr 'stepper-hide-reduction)))]
       [(result-exp-break)
        ;; skip if clauses that are the result of and/or reductions
        (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
@@ -185,7 +185,7 @@
     
     (and (pair? mark-list)
          (let ([expr (mark-source (car mark-list))])
-           (or (equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect)
+           (or (stepper-syntax-property expr 'stepper-hide-reduction)
                (kernel:kernel-syntax-case expr #f
                                           [id
                                            (identifier? expr)
@@ -584,8 +584,7 @@
   (define (hide-completed? stx)
     (syntax-case stx ()
       [(define-values (v) rhs)
-       (equal? (stepper-syntax-property #'v 'stepper-hint) 'comes-from-check-expect)
-       #t]
+       (stepper-syntax-property #'v 'stepper-hide-completed)]
       [else #f]))
   
                                                                                                                 
diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss
index 19a996c9a3..59b55eeb08 100644
--- a/collects/stepper/private/shared.ss
+++ b/collects/stepper/private/shared.ss
@@ -7,6 +7,8 @@
            mzlib/match
            srfi/26
            mzlib/class)
+  
+  (require (for-syntax mzlib/list))
 
   ; CONTRACTS
   
@@ -92,6 +94,7 @@
    language-level->name
    
    stepper-syntax-property
+   with-stepper-syntax-properties
 
    skipto/cdr
    skipto/cddr
@@ -101,7 +104,6 @@
    skipto/fourth
    skipto/firstarg)
   
-    
   ;; stepper-syntax-property : like syntax property, but adds properties to an association
   ;; list associated with the syntax property 'stepper-properties
   (define stepper-syntax-property
@@ -118,6 +120,15 @@
                                                 (or (syntax-property stx 'stepper-properties)
                                                     null)))]))
   
+  ;; with-stepper-syntax-properties : like stepper-syntax-property, but in a "let"-like form
+  (define-syntax (with-stepper-syntax-properties stx)
+    (syntax-case stx ()
+      [(_ ([property val] ...) body)
+       (foldl (lambda (property val b) #`(stepper-syntax-property #,b #,property #,val))
+              #'body
+              (syntax->list #`(property ...))
+              (syntax->list #`(val ...)))]))
+  
   ; A step-result is either:
   ; (make-before-after-result finished-exps exp redex reduct)
   ; or (make-before-error-result finished-exps exp redex err-msg)