Fixes a bug in the stepper's diff highlighting

collects/meta/props

@@ -1243,6 +1243,7 @@ path/s is either such a string or a list of them.
 "collects/redex/tests/matcher-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/pict-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/rg-test.rkt" drdr:command-line (mzc *)
+"collects/redex/tests/stepper-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/run-tests.rkt" drdr:command-line (gracket-text * "--examples" "--no-bitmaps") drdr:timeout 360
 "collects/redex/tests/term-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/tl-test.rkt" drdr:command-line (mzc *)

collects/redex/private/sexp-diffs.rkt

@@ -135,11 +135,13 @@
                       [pretty-print-size-hook
                        (λ (val dsp? port)
                          (if (wrap? val)
-                             (string-length (format "~s" (wrap-content val)))
-                             #f))]
+                             (or (default-pretty-printer-size-hook (wrap-content val) dsp? port)
+                                 (string-length (format "~s" (wrap-content val))))
+                             (default-pretty-printer-size-hook val dsp? port)))]
                       [pretty-print-print-hook
                        (λ (val dsp? port)
-                         (write (wrap-content val) port))]
+                         (let ([unwrapped (if (wrap? val) (wrap-content val) val)])
+                           (default-pretty-printer-print-hook unwrapped dsp? port)))]
                       [pretty-print-pre-print-hook
                        (λ (obj port)
                          (when (hash-ref diff-ht obj #f)

collects/redex/private/size-snip.rkt

@@ -9,6 +9,8 @@
          size-editor-snip%
          size-text%
          default-pretty-printer
+         default-pretty-printer-size-hook
+         default-pretty-printer-print-hook
          pretty-print-parameters
          initial-char-width
          resizing-pasteboard-mixin
@@ -26,22 +28,25 @@
   
 (define (default-pretty-printer v port w spec)
   (parameterize ([pretty-print-columns w]
-                 [pretty-print-size-hook
-                  (λ (val display? op)
+                 [pretty-print-size-hook default-pretty-printer-size-hook]
+                 [pretty-print-print-hook default-pretty-printer-print-hook])
+    ((pretty-print-parameters)
+     (λ ()
+       (pretty-print v port)))))
+
+(define (default-pretty-printer-size-hook val display? op)
   (cond
     [(hole? val) 4]
     [(eq? val 'hole) 6]
-                      [else #f]))]
-                 [pretty-print-print-hook
-                  (λ (val display? op)
+    [else #f]))
+
+(define (default-pretty-printer-print-hook val display? op)
   (cond
     [(hole? val)
      (display "hole" op)]
     [(eq? val 'hole) 
-                       (display ",'hole" op)]))])
-    ((pretty-print-parameters)
-     (λ ()
-       (pretty-print v port)))))
+     (display ",'hole" op)]
+    [else (display val op)]))
 
 (define reflowing-snip<%>
   (interface ()

collects/redex/private/stepper.rkt

@@ -25,7 +25,10 @@ todo:
          "size-snip.ss"
          "reduction-semantics.ss")
   
-  (provide stepper stepper/seed)
+  (provide stepper stepper/seed
+           
+           ; for testing
+           show-diff node%)
   
   (define dot-spacing 20)
   (define dot-size 10)
@@ -356,15 +359,8 @@ todo:
          (for-each (λ (node) (send (send node get-big-snip) clear-diffs))
                    col))
        path)
-      (let-values ([(to-color1 to-color2) 
-                    (find-differences 
-                     (send parent get-term)
-                     (send child get-term)
-                     (send (send parent get-big-snip) get-char-width)
-                     (send (send child get-big-snip) get-char-width))])
-        (send (send parent get-big-snip) highlight-diffs to-color1)
-        (send (send child get-big-snip) highlight-diffs to-color2)
-        (void))
+      
+      (show-diff parent child)
       
       (when red-name-message
         (let ([label (map (λ (x) (if x (format "[~a]" x) "≪unknown≫"))
@@ -443,6 +439,17 @@ todo:
     (pb-change-columns)
     (update-buttons))
   
+  (define (show-diff parent child)
+    (let-values ([(to-color1 to-color2) 
+                  (find-differences 
+                   (send parent get-term)
+                   (send child get-term)
+                   (send (send parent get-big-snip) get-char-width)
+                   (send (send child get-big-snip) get-char-width))])
+      (send (send parent get-big-snip) highlight-diffs to-color1)
+      (send (send child get-big-snip) highlight-diffs to-color2)
+      (void)))
+  
   (define (find-i term terms fail)
     (let loop ([i 0]
                [terms terms])

collects/redex/tests/run-tests.rkt

@@ -24,7 +24,8 @@
      "keyword-macros-test.ss"
      "core-layout-test.ss" 
      "pict-test.ss"
-     "hole-test.ss")
+     "hole-test.ss"
+     "stepper-test.ss")
    (if test-bitmaps? '("bitmap-test.ss") '())
    (if test-examples? 
        '("../examples/pi-calculus.ss"

collects/redex/tests/stepper-test.rkt

@@ -0,0 +1,37 @@
+#lang racket
+
+(require framework
+         "test-util.rkt"
+         "../reduction-semantics.rkt"
+         "../private/stepper.rkt"
+         "../private/size-snip.rkt")
+
+(reset-count)
+
+;; diff : term term -> (cons range range)
+;; range = (listof (cons nat nat))
+(define (diff from to)
+  (define (make-node t)
+    (new node%
+         [pp default-pretty-printer]
+         [all-nodes-ht 'dont-care]
+         [term t]
+         [red 'dont-care]
+         [change-path 'dont-care]
+         [init-cw (initial-char-width)]))
+  (define (ranges node)
+    (map (λ (range) (cons (text:range-start range)
+                          (text:range-end range)))
+         (send (send (send node get-big-snip) get-editor)
+               get-highlighted-ranges)))
+  (define from-node (make-node from))
+  (define to-node (make-node to))
+  (show-diff from-node to-node)
+  (cons (ranges from-node) (ranges to-node)))
+
+(test (diff (term (hole a)) (term (hole b)))
+      (cons (list (cons 6 7)) (list (cons 6 7))))
+(test (diff (term (,'hole a)) (term (,'hole b)))
+      (cons (list (cons 8 9)) (list (cons 8 9))))
+
+(print-tests-passed 'stepper-test.ss)