initial version of debugger stack view
to do: investigate graphical feedback for frame rollover/selection; update documentation svn: r9506
This commit is contained in:
Greg Cooper
parent
aa5eb38972
commit
30eb4e6a58
|
|
@ -799,12 +799,8 @@
|
||||||
res) (cdar bindings)]
|
res) (cdar bindings)]
|
||||||
[else (loop (rest bindings))])))
|
[else (loop (rest bindings))])))
|
||||||
|
|
||||||
(define/public (move-up-frame)
|
(define/public (move-to-frame the-frame-num)
|
||||||
(set-box! frame-num (add1 (unbox frame-num)))
|
(set-box! frame-num the-frame-num)
|
||||||
(suspend-gui (get-stack-frames) (get-break-status) #t))
|
|
||||||
|
|
||||||
(define/public (move-down-frame)
|
|
||||||
(set-box! frame-num (sub1 (unbox frame-num)))
|
|
||||||
(suspend-gui (get-stack-frames) (get-break-status) #t))
|
(suspend-gui (get-stack-frames) (get-break-status) #t))
|
||||||
|
|
||||||
(define/public (resume)
|
(define/public (resume)
|
||||||
|
|
@ -843,14 +839,17 @@
|
||||||
end
|
end
|
||||||
start)))))
|
start)))))
|
||||||
|
|
||||||
(define/public (get-current-frame-endpoints)
|
(define/public (get-frame-endpoints frame-num)
|
||||||
(let ([stack-frames (get-stack-frames)])
|
(let ([stack-frames (get-stack-frames)])
|
||||||
(and (cons? stack-frames)
|
(and (cons? stack-frames)
|
||||||
(let* ([src-stx (mark-source (list-ref stack-frames (get-frame-num)))]
|
(let* ([src-stx (mark-source (list-ref stack-frames frame-num))]
|
||||||
[start (syntax-position src-stx)]
|
[start (syntax-position src-stx)]
|
||||||
[end (and start (+ start (syntax-span src-stx) -1))])
|
[end (and start (+ start (syntax-span src-stx) -1))])
|
||||||
(list start end)))))
|
(list start end)))))
|
||||||
|
|
||||||
|
(define/public (get-current-frame-endpoints)
|
||||||
|
(get-frame-endpoints (get-frame-num)))
|
||||||
|
|
||||||
(define (do-in-user-thread thunk)
|
(define (do-in-user-thread thunk)
|
||||||
(if (get-break-status)
|
(if (get-break-status)
|
||||||
(channel-put in-user-ch thunk)
|
(channel-put in-user-ch thunk)
|
||||||
|
|
@ -919,9 +918,8 @@
|
||||||
(send (send (get-frame) get-step-button) enable top-of-stack?)
|
(send (send (get-frame) get-step-button) enable top-of-stack?)
|
||||||
(send (send (get-frame) get-step-over-button) enable (can-step-over? frames status))
|
(send (send (get-frame) get-step-over-button) enable (can-step-over? frames status))
|
||||||
(send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
|
(send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
|
||||||
(send (send (get-frame) get-up-frame-button) enable (can-move-up-frame? frames))
|
|
||||||
(send (send (get-frame) get-down-frame-button) enable (can-move-down-frame? frames))
|
|
||||||
(send (send (get-frame) get-resume-button) enable #t)
|
(send (send (get-frame) get-resume-button) enable #t)
|
||||||
|
(send (get-frame) register-stack-frames frames)
|
||||||
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
|
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
|
||||||
;;(printf "status = ~a~n" status)
|
;;(printf "status = ~a~n" status)
|
||||||
(send status-message set-label
|
(send status-message set-label
|
||||||
|
|
@ -942,7 +940,8 @@
|
||||||
"??")
|
"??")
|
||||||
(if (= 2 (length status))
|
(if (= 2 (length status))
|
||||||
(render (cadr status))
|
(render (cadr status))
|
||||||
(cons 'values (map (lambda (v) (render v)) (rest status)))))))]))
|
(cons 'values (map (lambda (v) (render v)) (rest status)))))))]
|
||||||
|
[""]))
|
||||||
""))
|
""))
|
||||||
(cond [(get-current-frame-endpoints)
|
(cond [(get-current-frame-endpoints)
|
||||||
=> (lambda (start/end)
|
=> (lambda (start/end)
|
||||||
|
|
@ -965,9 +964,8 @@
|
||||||
(send (send (get-frame) get-step-over-button) enable #f)
|
(send (send (get-frame) get-step-over-button) enable #f)
|
||||||
(send (send (get-frame) get-step-out-button) enable #f)
|
(send (send (get-frame) get-step-out-button) enable #f)
|
||||||
(send (send (get-frame) get-resume-button) enable #f)
|
(send (send (get-frame) get-resume-button) enable #f)
|
||||||
(send (send (get-frame) get-up-frame-button) enable #f)
|
|
||||||
(send (send (get-frame) get-down-frame-button) enable #f)
|
|
||||||
(send (send (get-frame) get-status-message) set-label "")
|
(send (send (get-frame) get-status-message) set-label "")
|
||||||
|
(send (get-frame) clear-stack-frames)
|
||||||
(send (get-defs) invalidate-bitmap-cache))
|
(send (get-defs) invalidate-bitmap-cache))
|
||||||
|
|
||||||
(define/public suspend
|
(define/public suspend
|
||||||
|
|
@ -1079,27 +1077,125 @@
|
||||||
this
|
this
|
||||||
'(ok))))))
|
'(ok))))))
|
||||||
|
|
||||||
|
(define max-stack-frames 40)
|
||||||
|
|
||||||
|
(define/public (register-stack-frames frames)
|
||||||
|
(let loop ([i 0] [frames frames])
|
||||||
|
(when (< i max-stack-frames)
|
||||||
|
(send (list-ref stack-frames i) set-expr
|
||||||
|
(and (cons? frames) (mark-source (first frames))))
|
||||||
|
(loop (add1 i) (and (cons? frames) (rest frames))))))
|
||||||
|
|
||||||
|
(define/public (clear-stack-frames)
|
||||||
|
(let loop ([i 0])
|
||||||
|
(when (< i max-stack-frames)
|
||||||
|
(send (list-ref stack-frames i) set-expr #f)
|
||||||
|
(loop (add1 i)))))
|
||||||
|
|
||||||
|
(define debug-grandparent-panel 'uninitialized-debug-grandparent-panel)
|
||||||
(define debug-parent-panel 'uninitialized-debug-parent-panel)
|
(define debug-parent-panel 'uninitialized-debug-parent-panel)
|
||||||
(define debug-panel 'uninitialized-debug-panel)
|
(define debug-panel 'uninitialized-debug-panel)
|
||||||
|
(define stack-view-panel 'uninitialized-stack-view-panel)
|
||||||
|
(define stack-frames 'uninitialized-stack-frames)
|
||||||
|
(define highlight-color (make-object color% 207 255 207))
|
||||||
|
(define mouse-over-frame #f)
|
||||||
|
(define refresh-timer (new timer% [notify-callback
|
||||||
|
(lambda ()
|
||||||
|
(unless mouse-over-frame
|
||||||
|
(send (get-current-tab) move-to-frame
|
||||||
|
(send (get-current-tab) get-frame-num))))]))
|
||||||
(define/override (get-definitions/interactions-panel-parent)
|
(define/override (get-definitions/interactions-panel-parent)
|
||||||
(set! debug-parent-panel
|
(set! debug-grandparent-panel
|
||||||
(make-object vertical-panel%
|
(make-object horizontal-panel%
|
||||||
(super get-definitions/interactions-panel-parent)))
|
(super get-definitions/interactions-panel-parent)))
|
||||||
|
(set! stack-view-panel
|
||||||
|
(new vertical-panel%
|
||||||
|
[parent debug-grandparent-panel]
|
||||||
|
[stretchable-width #f]))
|
||||||
|
(new message% [parent stack-view-panel] [label "Context"]
|
||||||
|
[font (make-object font% 18 'default 'normal 'bold #t)])
|
||||||
|
(set! stack-frames
|
||||||
|
(build-list max-stack-frames
|
||||||
|
(lambda (i)
|
||||||
|
(new (class message%
|
||||||
|
(super-new)
|
||||||
|
(inherit set-label get-label)
|
||||||
|
(define expr #f)
|
||||||
|
(define/public (set-expr expr1)
|
||||||
|
(set! expr expr1)
|
||||||
|
(set-label
|
||||||
|
(cond
|
||||||
|
; should succeed unless the user closes a slave tab during debugging
|
||||||
|
[(and expr (filename->defs (syntax-source expr)))
|
||||||
|
=>
|
||||||
|
(lambda (defs)
|
||||||
|
(clean-status
|
||||||
|
(if (syntax-position expr)
|
||||||
|
(send defs get-text
|
||||||
|
(sub1 (syntax-position expr))
|
||||||
|
(+ -1 (syntax-position expr) (syntax-span expr)))
|
||||||
|
"??")))]
|
||||||
|
[""])))
|
||||||
|
(define/override (on-subwindow-event msg evt)
|
||||||
|
(case (send evt get-event-type)
|
||||||
|
[(enter) (cond
|
||||||
|
[(and expr (filename->defs (syntax-source expr)))
|
||||||
|
=> (lambda (defs)
|
||||||
|
(send defs highlight-range
|
||||||
|
(sub1 (syntax-position expr))
|
||||||
|
(+ -1 (syntax-position expr)
|
||||||
|
(syntax-span expr))
|
||||||
|
highlight-color)
|
||||||
|
(cond
|
||||||
|
[(send defs get-filename)
|
||||||
|
=>
|
||||||
|
(lambda (fn)
|
||||||
|
(handler:edit-file fn))])
|
||||||
|
(send defs scroll-to-position
|
||||||
|
(syntax-position expr)))])
|
||||||
|
(when expr
|
||||||
|
(set! mouse-over-frame i))]
|
||||||
|
[(leave) (cond
|
||||||
|
[(and expr (filename->defs (syntax-source expr)))
|
||||||
|
=> (lambda (defs)
|
||||||
|
(send defs unhighlight-range
|
||||||
|
(sub1 (syntax-position expr))
|
||||||
|
(+ -1 (syntax-position expr)
|
||||||
|
(syntax-span expr))
|
||||||
|
highlight-color))])
|
||||||
|
(set! mouse-over-frame #f)
|
||||||
|
(when expr
|
||||||
|
(send refresh-timer start 250 #t))]
|
||||||
|
[(left-down) (when expr
|
||||||
|
(send (get-current-tab) move-to-frame i))])))
|
||||||
|
[parent stack-view-panel]
|
||||||
|
[stretchable-width #f]
|
||||||
|
[label (make-string 30 #\ )]))))
|
||||||
|
;; parent of panel with debug buttons
|
||||||
|
(set! debug-parent-panel
|
||||||
|
(make-object vertical-panel% debug-grandparent-panel))
|
||||||
|
;; horizontal panel with debug buttons; not vertically stretchable
|
||||||
(set! debug-panel (instantiate horizontal-panel% ()
|
(set! debug-panel (instantiate horizontal-panel% ()
|
||||||
(parent debug-parent-panel)
|
(parent debug-parent-panel)
|
||||||
(stretchable-height #f)
|
(stretchable-height #f)
|
||||||
(alignment '(center center))
|
(alignment '(center center))
|
||||||
(style '(border))))
|
(style '(border))))
|
||||||
|
;; hide the debug panel and stack view initially
|
||||||
(send debug-parent-panel change-children (lambda (l) null))
|
(send debug-parent-panel change-children (lambda (l) null))
|
||||||
|
(send debug-grandparent-panel change-children (lambda (l) (remq stack-view-panel l)))
|
||||||
(make-object vertical-panel% debug-parent-panel))
|
(make-object vertical-panel% debug-parent-panel))
|
||||||
|
|
||||||
(define/public (hide-debug)
|
(define/public (hide-debug)
|
||||||
(when (member debug-panel (send debug-parent-panel get-children))
|
(when (member debug-panel (send debug-parent-panel get-children))
|
||||||
|
(send debug-grandparent-panel change-children
|
||||||
|
(lambda (l) (remq stack-view-panel l)))
|
||||||
(send debug-parent-panel change-children
|
(send debug-parent-panel change-children
|
||||||
(lambda (l) (remq debug-panel l)))))
|
(lambda (l) (remq debug-panel l)))))
|
||||||
|
|
||||||
(define/public (show-debug)
|
(define/public (show-debug)
|
||||||
(unless (member debug-panel (send debug-parent-panel get-children))
|
(unless (member debug-panel (send debug-parent-panel get-children))
|
||||||
|
(send debug-grandparent-panel change-children
|
||||||
|
(lambda (l) (append l (list stack-view-panel))))
|
||||||
(send debug-parent-panel change-children
|
(send debug-parent-panel change-children
|
||||||
(lambda (l) (cons debug-panel l)))))
|
(lambda (l) (cons debug-panel l)))))
|
||||||
|
|
||||||
|
|
@ -1217,30 +1313,12 @@
|
||||||
[callback (make-big-step-callback #t)]
|
[callback (make-big-step-callback #t)]
|
||||||
[enabled #f]))
|
[enabled #f]))
|
||||||
|
|
||||||
(define up-frame-button
|
|
||||||
(new button%
|
|
||||||
[label ((bitmap-label-maker
|
|
||||||
"Up"
|
|
||||||
(build-path (collection-path "gui-debugger" "icons") "up.png")) this)]
|
|
||||||
[parent debug-panel]
|
|
||||||
[callback (lambda (btn evt) (send (get-current-tab) move-up-frame))] [enabled #f]))
|
|
||||||
|
|
||||||
(define down-frame-button
|
|
||||||
(new button%
|
|
||||||
[label ((bitmap-label-maker
|
|
||||||
"Down"
|
|
||||||
(build-path (collection-path "gui-debugger" "icons") "down.png")) this)]
|
|
||||||
[parent debug-panel]
|
|
||||||
[callback (lambda (btn evt) (send (get-current-tab) move-down-frame))] [enabled #f]))
|
|
||||||
|
|
||||||
(define/public (get-debug-button) debug-button)
|
(define/public (get-debug-button) debug-button)
|
||||||
(define/public (get-pause-button) pause-button)
|
(define/public (get-pause-button) pause-button)
|
||||||
(define/public (get-resume-button) resume-button)
|
(define/public (get-resume-button) resume-button)
|
||||||
(define/public (get-step-button) step-button)
|
(define/public (get-step-button) step-button)
|
||||||
(define/public (get-step-over-button) step-over-button)
|
(define/public (get-step-over-button) step-over-button)
|
||||||
(define/public (get-step-out-button) step-out-button)
|
(define/public (get-step-out-button) step-out-button)
|
||||||
(define/public (get-up-frame-button) up-frame-button)
|
|
||||||
(define/public (get-down-frame-button) down-frame-button)
|
|
||||||
(define/public (get-status-message) status-message)
|
(define/public (get-status-message) status-message)
|
||||||
|
|
||||||
(define mouse-over-message
|
(define mouse-over-message
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user