(module stepper mzscheme
(require (lib "pretty.ss")
(lib "mred.ss" "mred")
(lib "class.ss")
"reduction-semantics.ss")
(define (step lang red term)
(define f (new stepper-frame%))
(send f show #t))
(define stepper-frame%
(class frame%
(init-field left-column)
(define/public (add-column los) ...)))
(define (record-differences sexp1 sexp2)
(let ([ht (make-hash-table)])
(let loop ([sexp1 sexp1]
[sexp2 sexp2])
(cond
[(eq? sexp1 sexp2) (void)]
[(and (pair? sexp1)
(pair? sexp2)
(equal? (d-length sexp1)
(d-length sexp2)))
(for-each/d loop sexp1 sexp2)]
[(equal? sexp1 sexp2) (void)]
[else
(hash-table-put! ht sexp1 #t)
(hash-table-put! ht sexp2 #t)]))))
(define (show-differences s1 s2)
(define diff-ht (record-differences s1 s2))
(define f (new frame% [label ""] [width 600] [height 500]))
(define hp (new horizontal-panel% [parent f]))
(define t1 (new text%))
(define t2 (new text%))
(define c1 (new editor-canvas%
[parent hp]
[editor t1]))
(define c2 (new editor-canvas%
[parent hp]
[editor t2]))
(render-sexp/colors s1 diff-ht t1)
(render-sexp/colors s2 diff-ht t2)
(send f show #t))
(define (render-sexp/colors sexp diff-ht text)
(parameterize ([pretty-print-columns 30])
(pretty-print sexp (open-output-text-editor text)))
(send text change-style
(make-object style-delta% 'change-family 'modern)
0
(send text last-position)))
(define (for-each/d f l1 l2)
(let loop ([l1 l1]
[l2 l2])
(cond
[(pair? l1)
(f (car l1) (car l2))
(loop (cdr l1) (cdr l2))]
[(null? l1) (void)]
[else (f l1 l2)])))
(define (d-length l1)
(let loop ([l1 l1]
[n 0])
(cond
[(pair? l1) (loop (cdr l1) (+ n 1))]
[(null? l1) n]
[else (cons 'dotted (+ n 1))])))
(show-differences
'(store
()
(((call/cc
(throw
x3
((x3
(throw
x2
(((lambda (x) ((call/cc call/cc) x)) x2)))))))
(throw x2 (((lambda (x) ((call/cc call/cc) x)) x2))))))
'(store
()
((begin
1
((values
(throw
x4
((x4
(throw
x2
(((lambda (x) ((call/cc call/cc) x)) x2)))))))
(throw
x2
(((lambda (x) ((call/cc call/cc) x)) x2)))))))))