(module trace-sidebar mzscheme (require (lib "contract.ss") (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss") "interfaces.ss" "util-mixins.ss" "pasteboard-mixins.ss" "snip-mixins.ss" "trace-header.ss" "draw.ss" "../model/view.ss" "../model/action-util.ss" ) (provide/contract [trace-sidebar% (class/c editor-canvas% updatee<%>)]) (define trace-sidebar% (class* (ensure-iface editor-canvas-util<%> editor-canvas-util-mixin editor-canvas%) (updatee<%>) (inherit set-editor) (init-field trace-display) (super-new [style '(auto-hscroll auto-vscroll)] [min-width (+ SIDEBAR-WIDTH SCROLLBAR-WIDTH)] [horizontal-inset 0] [vertical-inset 0]) (public on-update) (override on-scroll/xy) (define editor (new trace-action-editor% [trace-display trace-display])) (set-editor editor) (define (on-scroll/xy x y dx dy) (unless (= 0 dy) (send trace-display scroll-trace/xy #f y))) (define (on-update) (send editor on-update)))) (define trace-action-editor% (class* (ensure-iface pasteboard-util<%> pasteboard-util-mixin (static-pasteboard-mixin pasteboard%)) (updatee<%>) (super-new) (inherit insert) (init-field trace-display) (public on-update) (override on-double-click) (define sidebar-snip (new trace-sidebar-snip% [trace-display trace-display])) (insert sidebar-snip 0 0) (on-update) (define (on-double-click snip event) (send sidebar-snip on-double-click event)) (define (on-update) (send sidebar-snip on-update)) )) (define SIDEBAR-LABEL-HORIZ-OFFSET 10) (define SIDEBAR-LABEL-VERT-OFFSET 10) (define SIDEBAR-ARROW-HORIZ-OFFSET 10) (define SIDEBAR-ARROW-VERT-OFFSET 12) (define trace-sidebar-snip% (class (updatable-snip-mixin (custom-snip-mixin snip%)) (super-new) (inherit get-admin) (init-field trace-display) (override paint extent) (public on-double-click) (private get-view) (define (get-view) (send trace-display get-view)) (define (on-double-click event) (let*-values ([(x y) (send (send (get-admin) get-editor) dc-location-to-editor-location (send event get-x) (send event get-y))] [(action-index) (inexact->exact (floor (/ y ACTION-HEIGHT)))]) (when (<= 0 action-index (- (view-count-actions (get-view)) 1)) (let* ([action (view-get-action (get-view) action-index)] [object (cond [(<= 0 x (* SIDEBAR-WIDTH 1/3)) (action-source action)] [(<= (* SIDEBAR-WIDTH 2/3) x SIDEBAR-WIDTH) (action-target action)] [else #f])]) (when object (send trace-display scroll-trace/object object)))))) (define (extent dc x y) (values SIDEBAR-WIDTH (view-height (get-view)) 0 0 0 0)) (define (paint easel) (draw-sidebar easel (get-view))))) )