suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes a bug in the stepper's diff highlighting

Browse Source
This commit is contained in:
Casey Klein 2011-03-29 10:41:01 -05:00
parent 1788703a42
commit df3bc8980b
6 changed files with 80 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/meta/props
View File

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

8
collects/redex/private/sexp-diffs.rkt
View File

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

31
collects/redex/private/size-snip.rkt
View File

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

27
collects/redex/private/stepper.rkt
View File

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

3
collects/redex/tests/run-tests.rkt
View File

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

37
collects/redex/tests/stepper-test.rkt Normal file
View File

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