From df3bc8980bce77a0b0ae47a5ef7cd87e87d855b0 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 29 Mar 2011 10:41:01 -0500 Subject: [PATCH] Fixes a bug in the stepper's diff highlighting --- collects/meta/props | 1 + collects/redex/private/sexp-diffs.rkt | 8 +++--- collects/redex/private/size-snip.rkt | 31 ++++++++++++---------- collects/redex/private/stepper.rkt | 27 +++++++++++-------- collects/redex/tests/run-tests.rkt | 3 ++- collects/redex/tests/stepper-test.rkt | 37 +++++++++++++++++++++++++++ 6 files changed, 80 insertions(+), 27 deletions(-) create mode 100644 collects/redex/tests/stepper-test.rkt diff --git a/collects/meta/props b/collects/meta/props index 6b981dfecb..7abc8e33d6 100755 --- a/collects/meta/props +++ b/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 *) diff --git a/collects/redex/private/sexp-diffs.rkt b/collects/redex/private/sexp-diffs.rkt index 2fc2a83b25..121ad16724 100644 --- a/collects/redex/private/sexp-diffs.rkt +++ b/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) diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index 49324b7faf..d452b9e50b 100644 --- a/collects/redex/private/size-snip.rkt +++ b/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,23 +28,26 @@ (define (default-pretty-printer v port w spec) (parameterize ([pretty-print-columns w] - [pretty-print-size-hook - (λ (val display? op) - (cond - [(hole? val) 4] - [(eq? val 'hole) 6] - [else #f]))] - [pretty-print-print-hook - (λ (val display? op) - (cond - [(hole? val) - (display "hole" op)] - [(eq? val 'hole) - (display ",'hole" 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])) + +(define (default-pretty-printer-print-hook val display? op) + (cond + [(hole? val) + (display "hole" op)] + [(eq? val 'hole) + (display ",'hole" op)] + [else (display val op)])) + (define reflowing-snip<%> (interface () reflow-program)) diff --git a/collects/redex/private/stepper.rkt b/collects/redex/private/stepper.rkt index 1b0f753bd4..67471bc03b 100644 --- a/collects/redex/private/stepper.rkt +++ b/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]) diff --git a/collects/redex/tests/run-tests.rkt b/collects/redex/tests/run-tests.rkt index 84c63eb964..cfd10ecd48 100644 --- a/collects/redex/tests/run-tests.rkt +++ b/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" diff --git a/collects/redex/tests/stepper-test.rkt b/collects/redex/tests/stepper-test.rkt new file mode 100644 index 0000000000..aed8332f66 --- /dev/null +++ b/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) \ No newline at end of file