(module driver mzscheme (require (lib "class.ss") (lib "class-events.ss" "mzlib" "private") (lib "mred.ss" "mred") (lib "plt-match.ss") "gui/trace-display.ss" "model/buffer.ss" "model/view.ss" ) (provide with-trace-window install-trace-window sequence-trace-handler current-sequence-trace-buffer) (define current-sequence-trace-buffer (make-parameter #f)) (define (sequence-trace-handler . args) (let* ([buffer (current-sequence-trace-buffer)]) (and buffer (match args [(list 'new class object fields) (buffer-add! buffer (list 'new object fields))] [(list 'inspect object) (buffer-add! buffer (list 'inspect object))] [(list 'get object field) (buffer-add! buffer (list 'get object field))] [(list 'set object field value) (buffer-add! buffer (list 'set object field value))] [(list 'call object method args) (buffer-add! buffer (list 'call object method args)) (lambda returned-values (buffer-add! buffer (list 'return returned-values)))])))) (define (display-buffer buffer) (parameterize ([current-eventspace (make-eventspace)]) (define view (make-view buffer (lambda any #t))) (define frame (new frame% [label "Sequence Trace"])) (define gui (new trace-display% [parent frame] [view view])) (send frame show #t))) (define (install-trace-window) (let* ([buffer (make-buffer)]) (display-buffer buffer) (current-sequence-trace-buffer buffer) (current-class-event-handler sequence-trace-handler))) (define (with-trace-window/proc thunk) (let* ([buffer (make-buffer)]) (display-buffer buffer) (parameterize ([current-class-event-handler sequence-trace-handler] [current-sequence-trace-buffer buffer]) (thunk)))) (define-syntax (with-trace-window stx) (syntax-case stx () [(form . body) (syntax/loc stx (with-trace-window/proc (lambda () . body)))])) )