993cd40208
For example, a new DrRacket window (with a file named tmp.rkt in the and 356 afterwards. This is under mac os x with, I believe, the default system font sizes. (The file is important because different languages can have different buttons in the toolbar and the filename's length itself can affect the minimum size.) Mostly this change is the addition of a new kind of panel that lets its children have multiple fixed sizes (as opposed to just a single minimum size and (optionally arbitrarily large)) It also adjusts the various toolbar buttons to use this new code. Also, there's a few tweaks to shrink other things that became the limiting factor in shrinking the width of the DrRacket window. Currently, at least for #lang racket programs, the toolbar buttons along the top of the window are the limiting factor (including the save button). With a bogus language (ie, #lang rackeeet), the bottom bar is the limiting factor, since that will have only the Save, Run, and Stop buttons. related to PR 13281
1540 lines
75 KiB
Racket
1540 lines
75 KiB
Racket
#lang racket/base
|
|
|
|
;; DrRacket's debugging tool
|
|
|
|
(require racket/function
|
|
racket/list
|
|
racket/class
|
|
racket/unit
|
|
racket/contract
|
|
racket/match
|
|
racket/gui
|
|
drscheme/tool
|
|
"marks.rkt"
|
|
mrlib/switchable-button
|
|
mrlib/bitmap-label
|
|
mrlib/close-icon
|
|
"annotator.rkt"
|
|
"load-sandbox.rkt"
|
|
framework
|
|
string-constants
|
|
lang/debugger-language-interface
|
|
images/compile-time
|
|
(for-syntax racket/base
|
|
racket/class
|
|
racket/draw
|
|
images/icons/arrow
|
|
images/icons/control
|
|
images/icons/style
|
|
images/icons/symbol
|
|
images/icons/tool
|
|
slideshow/pict))
|
|
|
|
(provide tool@)
|
|
|
|
; QUESTIONS/IDEAS
|
|
; what is the right way to deal with macros?
|
|
; how can the three tool classes communicate with each other safely
|
|
|
|
(define-local-member-name debug-callback)
|
|
|
|
(preferences:set-default 'plt:debug-tool:stack/variable-area
|
|
9/10
|
|
(λ (x) (and (real? x) (<= 0 x 1))))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
(define (phase1)
|
|
(drscheme:module-language-tools:add-opt-out-toolbar-button
|
|
(λ (frame parent)
|
|
(new switchable-button%
|
|
(label (string-constant debug-tool-button-name))
|
|
(bitmap debug-bitmap)
|
|
(alternate-bitmap small-debug-bitmap)
|
|
(parent parent)
|
|
(callback (λ (button) (send frame debug-callback)))))
|
|
'macro-stepper)
|
|
(drscheme:language:extend-language-interface
|
|
debugger-language<%>
|
|
(lambda (superclass)
|
|
(class* superclass (debugger-language<%>)
|
|
(public debugger:supported?)
|
|
(define (debugger:supported?) #t)
|
|
(super-instantiate ())))))
|
|
(define phase2 void)
|
|
|
|
(define (extract-language-level settings)
|
|
(drscheme:language-configuration:language-settings-language settings))
|
|
|
|
(define (debugger-does-not-work-for? lang)
|
|
(not (send lang debugger:supported?)))
|
|
|
|
(define (robust-syntax-source stx)
|
|
(and (syntax? stx) (syntax-source stx)))
|
|
|
|
(define (robust-vector-ref vec idx)
|
|
(if (< idx (vector-length vec))
|
|
(vector-ref vec idx)
|
|
#f))
|
|
|
|
(define (safe-vector-set! vec idx val)
|
|
(when (< idx (vector-length vec))
|
|
(vector-set! vec idx val))
|
|
(void))
|
|
|
|
(define (truncate str n)
|
|
(cond [(< (string-length str) n) str]
|
|
[(>= n 3) (string-append
|
|
(substring str 0 (- n 3))
|
|
"...")]
|
|
[else (substring str 0 (min n (string-length str)))]))
|
|
|
|
(define (clean-status s)
|
|
(truncate (regexp-replace* #rx"\n" s " ") 200))
|
|
|
|
(define (index-of chr str)
|
|
(let loop ([i 0])
|
|
(if (< i (string-length str))
|
|
(if (char=? chr (string-ref str i))
|
|
i
|
|
(loop (add1 i)))
|
|
#f)))
|
|
|
|
(define (safe-min . args)
|
|
(apply min (filter identity args)))
|
|
|
|
;; trim-expr-str: string -> string
|
|
;; examples:
|
|
;; short-id => short-id
|
|
;; really-long-identifier => really-lon...
|
|
;; (<form>) => (<form>)
|
|
;; (<form> <arg1> ... <argn>) => (<form> ...)
|
|
(define trim-expr-str
|
|
(lambda (str [len 10])
|
|
(let* ([strlen (string-length str)]
|
|
[starts-with-paren (and (> strlen 0)
|
|
(char=? (string-ref str 0) #\())]
|
|
[len2 (+ len 4)]
|
|
[trunc-pos (safe-min (index-of #\space str)
|
|
(index-of #\newline str)
|
|
(and (> strlen len2) len)
|
|
strlen)])
|
|
(if (>= trunc-pos strlen)
|
|
str
|
|
(string-append
|
|
(substring str 0 trunc-pos)
|
|
(if starts-with-paren
|
|
" ...)"
|
|
" ..."))))))
|
|
|
|
(define (average . values)
|
|
(/ (apply + values) (length values)))
|
|
|
|
(define (truncate-value v size depth)
|
|
(cond
|
|
[(zero? depth) '...]
|
|
[(and (string? v)
|
|
(> (string-length v) size))
|
|
(string-append (substring v 0 size) "...")]
|
|
[(list? v)
|
|
(let* ([len (length v)]
|
|
[res (build-list (min size len)
|
|
(lambda (i) (truncate-value (list-ref v i) size (sub1 depth))))])
|
|
(if (> len size) (append res (list '...)) res))]
|
|
[(vector? v)
|
|
(build-vector (min size (vector-length v))
|
|
(lambda (i)
|
|
(if (and (= i (sub1 size))
|
|
(> size (vector-length v)))
|
|
'...
|
|
(truncate-value (vector-ref v i) size (sub1 depth)))))]
|
|
[(bytes? v)
|
|
(if (> (bytes-length v) size)
|
|
(bytes-append (subbytes v 0 size) #"...")
|
|
v)]
|
|
[else v]))
|
|
|
|
(define filename->defs
|
|
(lambda (source [default #f])
|
|
(let/ec k
|
|
(cond
|
|
[(is-a? source editor<%>) source]
|
|
[else
|
|
(send (group:get-the-frame-group) for-each-frame
|
|
(lambda (frame)
|
|
(and (is-a? frame drscheme:unit:frame<%>)
|
|
(let* ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))]
|
|
[defs (findf (lambda (d) (send d port-name-matches? source)) defss)])
|
|
(and defs (k defs))))))
|
|
default]))))
|
|
|
|
(define (debug-definitions-text-mixin super%)
|
|
(class super%
|
|
|
|
(inherit dc-location-to-editor-location
|
|
editor-location-to-dc-location
|
|
invalidate-bitmap-cache
|
|
begin-edit-sequence
|
|
end-edit-sequence
|
|
get-canvas
|
|
get-top-level-window
|
|
get-filename
|
|
get-tab)
|
|
|
|
(define mouse-over-pos #f)
|
|
(super-instantiate ())
|
|
|
|
(define/augment (on-delete start len)
|
|
(begin-edit-sequence)
|
|
(let ([breakpoints (send (get-tab) get-breakpoints)]
|
|
[shifts empty])
|
|
(hash-for-each
|
|
breakpoints
|
|
(lambda (pos status)
|
|
(cond
|
|
; deletion after breakpoint: no effect
|
|
[(<= pos start)]
|
|
; deletion of breakpoint: remove from table
|
|
[(and (< start pos)
|
|
(<= pos (+ start len)))
|
|
(hash-remove! breakpoints pos)]
|
|
; deletion before breakpoint: shift breakpoint
|
|
[(> pos (+ start len))
|
|
(hash-remove! breakpoints pos)
|
|
(set! shifts (cons (cons (- pos len) status) shifts))])))
|
|
(for-each (lambda (p) (hash-set! breakpoints (car p) (cdr p)))
|
|
shifts))
|
|
(inner (void) on-delete start len))
|
|
|
|
(define/augment (after-delete start len)
|
|
(inner (void) after-delete start len)
|
|
(when (send (get-tab) debug?)
|
|
(send (get-tab) hide-debug))
|
|
(end-edit-sequence))
|
|
|
|
(define/augment (on-insert start len)
|
|
(begin-edit-sequence)
|
|
(let ([breakpoints (send (get-tab) get-breakpoints)]
|
|
[shifts empty])
|
|
(hash-for-each
|
|
breakpoints
|
|
(lambda (pos status)
|
|
(when (< start pos)
|
|
;; text inserted before this breakpoint, so shift
|
|
;; the breakpoint forward by <len> positions
|
|
(hash-remove! breakpoints pos)
|
|
(set! shifts (cons (cons (+ pos len) status) shifts)))))
|
|
;; update the breakpoint locations
|
|
(for-each (lambda (p) (hash-set! breakpoints (car p) (cdr p)))
|
|
shifts))
|
|
(inner (void) on-insert start len))
|
|
|
|
(define/augment (after-insert start len)
|
|
(inner (void) after-insert start len)
|
|
(when (send (get-tab) debug?)
|
|
(send (get-tab) hide-debug))
|
|
(end-edit-sequence))
|
|
|
|
;; lookup id in the given set of stack frames;
|
|
;; if that fails, try the top-level environment
|
|
;; invokes sk on success, fk on failure
|
|
(define/private (lookup-var id frames sk fk)
|
|
(cond
|
|
[(and id frames (lookup-first-binding
|
|
(lambda (id2) (free-identifier=? id id2))
|
|
frames (lambda () #f)))
|
|
=> (lambda (binding)
|
|
(sk (mark-binding-value binding)
|
|
(lambda (v) (mark-binding-set! binding v))))]
|
|
[(and id (send (get-tab) lookup-top-level-var
|
|
id (lambda () #f)))
|
|
=> (lambda (tlb)
|
|
(sk (tlb) tlb))]
|
|
[else (fk)]))
|
|
|
|
;; mouse-event -> (or (values #f #f) (values pos editor))
|
|
(define/private (get-pos/text event)
|
|
(let ([event-x (send event get-x)]
|
|
[event-y (send event get-y)]
|
|
[on-it? (box #f)])
|
|
(let loop ([editor this])
|
|
(let-values ([(x y) (send editor dc-location-to-editor-location
|
|
event-x event-y)])
|
|
(cond
|
|
[(is-a? editor text%)
|
|
(let ([pos (send editor find-position x y #f on-it?)])
|
|
(cond
|
|
[(not (unbox on-it?)) (values #f #f)]
|
|
[else
|
|
(let ([snip (send editor find-snip pos 'after-or-none)])
|
|
(if (and snip
|
|
(is-a? snip editor-snip%))
|
|
(loop (send snip get-editor))
|
|
(values pos editor)))]))]
|
|
[(is-a? editor pasteboard%)
|
|
(let ([snip (send editor find-snip x y)])
|
|
(if (and snip
|
|
(is-a? snip editor-snip%))
|
|
(loop (send snip get-editor))
|
|
(values #f #f)))]
|
|
[else (values #f #f)])))))
|
|
|
|
;; text% start -> (values left top right bottom)
|
|
;; (four numbers that indicate the locations in pixels of the
|
|
;; box bounding the text between start and end
|
|
(define/private (find-char-box text pos)
|
|
(define start-pos (max 0 (- pos 1)))
|
|
(define end-pos (+ start-pos 1))
|
|
(let ([xlb (box 0)]
|
|
[ylb (box 0)]
|
|
[xrb (box 0)]
|
|
[yrb (box 0)])
|
|
(send text position-location start-pos xlb ylb #t)
|
|
(send text position-location end-pos xrb yrb #f)
|
|
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
|
|
(unbox xlb) (unbox ylb))]
|
|
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
|
|
[(xr-off yr-off) (send text editor-location-to-dc-location
|
|
(unbox xrb) (unbox yrb))]
|
|
[(xr yr) (dc-location-to-editor-location xr-off yr-off)])
|
|
(cond
|
|
[(= (send text position-line start-pos)
|
|
(send text position-line end-pos))
|
|
(values xl yl xr yr)]
|
|
[else
|
|
;; in this case, the open paren we want to draw on top of is on
|
|
;; a different line from the operator following it, so we just
|
|
;; give ourselves a little space and draw something, instead of
|
|
;; returning strange results (and possibly crashing)
|
|
(values xl yl (+ 10 xl) (+ yl 10))]))))
|
|
|
|
(define/private (render v)
|
|
(send (get-tab) render v))
|
|
|
|
;; mouse-event% integer -> ()
|
|
;; handles a right-click on a position that's not a breakable paren
|
|
(define/private (debugger-handle-right-click-non-breakable event pos)
|
|
(let* ([frames (send (get-tab) get-stack-frames)]
|
|
[pos-vec (send (get-tab) get-pos-vec)]
|
|
[id (robust-vector-ref pos-vec pos)])
|
|
(unless (lookup-var
|
|
id frames
|
|
(lambda (val wr)
|
|
(let ([id-sym (syntax-e id)]
|
|
[menu (make-object popup-menu% #f)])
|
|
(make-object menu-item%
|
|
(clean-status (format "Print value of ~a to console" id-sym))
|
|
menu
|
|
(lambda (item evt)
|
|
(send (get-tab) print-to-console (format "~a = ~s" id-sym val))))
|
|
(make-object menu-item% (format "(set! ~a ...)" id-sym) menu
|
|
(lambda (item evt)
|
|
(let* ([tmp (get-text-from-user
|
|
(format "New value for ~a" id-sym) #f #f
|
|
(format "~a" val))])
|
|
(when tmp
|
|
(let/ec k
|
|
(wr (with-handlers
|
|
([exn:fail?
|
|
(lambda (exn)
|
|
(message-box
|
|
"Debugger Error"
|
|
(format "The following error occurred: ~a"
|
|
(exn-message exn)))
|
|
(k))])
|
|
(read (open-input-string tmp)))))))))
|
|
(send (get-canvas) popup-menu menu
|
|
(+ 1 (inexact->exact (floor (send event get-x))))
|
|
(+ 1 (inexact->exact (floor (send event get-y)))))
|
|
#t))
|
|
(lambda () #f))
|
|
(super on-event event))))
|
|
|
|
(define/private (debugger-handle-right-click-breakable event breakpoints pos break-status)
|
|
(let ([menu (make-object popup-menu% #f)])
|
|
(make-object menu-item%
|
|
(if break-status
|
|
"Remove pause at this point"
|
|
"Pause at this point")
|
|
menu
|
|
(lambda (item evt)
|
|
(hash-set! breakpoints pos (not break-status))
|
|
(invalidate-bitmap-cache)))
|
|
(let ([pc (send (get-tab) get-pc)])
|
|
(if (and pc (= pos pc))
|
|
(let* ([stat (send (get-tab) get-break-status)]
|
|
[f (get-top-level-window)]
|
|
[rendered-value
|
|
(if (cons? stat)
|
|
(if (= 2 (length stat))
|
|
(render (cadr stat))
|
|
(format "~s" (cons 'values
|
|
(map (lambda (v) (render v)) (rest stat)))))
|
|
"")])
|
|
(when (cons? stat)
|
|
(make-object menu-item%
|
|
"Print return value to console" menu
|
|
(lambda _ (send (get-tab) print-to-console
|
|
(string-append "return val = " rendered-value)))))
|
|
(when (not (eq? stat 'break))
|
|
(make-object menu-item%
|
|
(if (cons? stat)
|
|
"Change return value..."
|
|
"Skip expression...")
|
|
menu
|
|
(lambda (item evt)
|
|
(let ([tmp (get-text-from-user "Return value" #f)])
|
|
(when tmp
|
|
(let/ec k
|
|
(send (get-tab) set-break-status
|
|
(cons 'exit-break
|
|
(call-with-values
|
|
(lambda ()
|
|
(with-handlers
|
|
([exn:fail?
|
|
(lambda (exn)
|
|
(message-box
|
|
"Debugger Error"
|
|
(format "An error occurred: ~a" (exn-message exn))
|
|
#f '(ok))
|
|
(k))])
|
|
(read (open-input-string tmp))))
|
|
list)))
|
|
(invalidate-bitmap-cache))))))))
|
|
(make-object menu-item%
|
|
"Continue to this point"
|
|
menu
|
|
(lambda (item evt)
|
|
(hash-set!
|
|
breakpoints pos
|
|
(lambda () (hash-set! breakpoints pos break-status) #t))
|
|
(invalidate-bitmap-cache)
|
|
(when (send (get-tab) get-stack-frames)
|
|
(send (get-tab) resume))))))
|
|
(send (get-canvas) popup-menu menu
|
|
(+ 1 (inexact->exact (floor (send event get-x))))
|
|
(+ 1 (inexact->exact (floor (send event get-y)))))))
|
|
|
|
(define/private (debugger-handle-right-click event breakpoints)
|
|
(let-values ([(pos text) (get-pos/text event)])
|
|
(if (and pos text)
|
|
(let* ([pos (add1 pos)]
|
|
[break-status (hash-ref breakpoints pos (lambda () 'invalid))])
|
|
(match break-status
|
|
[(or #t #f (? procedure?))
|
|
(debugger-handle-right-click-breakable event breakpoints pos break-status)]
|
|
['invalid
|
|
(debugger-handle-right-click-non-breakable event pos)]))
|
|
(super on-event event))))
|
|
|
|
(define/private (debugger-handle-event event)
|
|
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
|
(cond
|
|
[(send event leaving?)
|
|
(when mouse-over-pos
|
|
(set! mouse-over-pos #f)
|
|
(invalidate-bitmap-cache))
|
|
(super on-event event)]
|
|
[(or (send event moving?)
|
|
(send event entering?))
|
|
(let-values ([(pos text) (get-pos/text event)])
|
|
(when (and pos text)
|
|
(let ([pos (add1 pos)])
|
|
(cond
|
|
;; mouse on breakable pos and hasn't moved significantly
|
|
[(eq? pos mouse-over-pos)]
|
|
;; mouse on new breakable pos
|
|
[(not (eq? (hash-ref
|
|
breakpoints pos (lambda () 'invalid)) 'invalid))
|
|
(set! mouse-over-pos pos)
|
|
(invalidate-bitmap-cache)]
|
|
;; moved off breakable pos
|
|
[mouse-over-pos
|
|
(set! mouse-over-pos #f)
|
|
(invalidate-bitmap-cache)])
|
|
(let* ([frames (send (get-tab) get-stack-frames)]
|
|
[pos-vec (send (get-tab) get-pos-vec)]
|
|
[id (robust-vector-ref pos-vec pos)]
|
|
;; Try to look up the identifier and render its value. If either
|
|
;; of these steps fails, just draw an empty string in the status bar.
|
|
[rendered
|
|
(lookup-var
|
|
id (list-tail frames (send (get-tab) get-frame-num))
|
|
;; id found
|
|
(lambda (val _)
|
|
(cond
|
|
[(render val) => (lambda (str)
|
|
(string-append
|
|
(symbol->string (syntax-e id)) " = " str))]
|
|
[else ""]))
|
|
;; id not found
|
|
(lambda () ""))])
|
|
(send (get-tab) set-mouse-over-msg (clean-status rendered))))))
|
|
(super on-event event)]
|
|
[(send event button-down? 'right)
|
|
(debugger-handle-right-click event breakpoints)]
|
|
[else (super on-event event)])))
|
|
|
|
(define/override (on-event event)
|
|
(if (send (get-tab) debug?)
|
|
(debugger-handle-event event)
|
|
(super on-event event)))
|
|
|
|
(define/override (on-paint before dc left top right bottom dx dy draw-caret)
|
|
(super on-paint before dc left top right bottom dx dy draw-caret)
|
|
(when (and (send (get-tab) debug?) (not before))
|
|
;; render breakpoints
|
|
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
|
(hash-for-each
|
|
breakpoints
|
|
(lambda (pos enabled?)
|
|
(when (and (>= pos 0) (or enabled? (and mouse-over-pos (= mouse-over-pos pos))))
|
|
(let*-values ([(xl yl xr yr) (find-char-box this pos)]
|
|
[(diameter) (- xr xl)]
|
|
[(yoff) (/ (- yr yl diameter) 2)])
|
|
(let ([op (send dc get-pen)]
|
|
[ob (send dc get-brush)])
|
|
(case enabled?
|
|
[(#t) (send dc set-pen bp-pen)
|
|
(send dc set-brush bp-brush)]
|
|
[(#f) (send dc set-pen bp-mo-pen)
|
|
(send dc set-brush bp-mo-brush)]
|
|
[else (send dc set-pen bp-tmp-pen)
|
|
(send dc set-brush bp-tmp-brush)])
|
|
(send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
|
|
(send dc set-pen op)
|
|
(send dc set-brush ob)))))))
|
|
;; mark the boundaries of the current stack frame
|
|
;; unless we're at the end of the expression and looking at the top frame,
|
|
;; in which case just mark the current location
|
|
(let* ([frame-defs (send (get-tab) defs-containing-current-frame)]
|
|
[pos (send (get-tab) get-current-frame-endpoints)]
|
|
[start (and pos (first pos))]
|
|
[end (and pos (second pos))]
|
|
[frame-num (send (get-tab) get-frame-num)]
|
|
[break-status (send (get-tab) get-break-status)])
|
|
(when (and (eq? frame-defs this) start end)
|
|
(let*-values ([(xl yl xr yr) (find-char-box this start)]
|
|
[(ym) (average yl yr)]
|
|
[(xa ya xb yb) (find-char-box this end)]
|
|
[(diameter) (- xb xa)]
|
|
[(yoff) (/ (- yb ya diameter) 2)]
|
|
[(ym2) (average ya yb)])
|
|
(let ([op (send dc get-pen)]
|
|
[ob (send dc get-brush)])
|
|
(cond
|
|
[(and (zero? frame-num)
|
|
(eq? break-status 'error))
|
|
(send dc set-pen pc-err-pen)
|
|
(send dc set-brush pc-err-brush)]
|
|
[(and (zero? frame-num)
|
|
(eq? break-status 'break))
|
|
(send dc set-pen pc-brk-pen)
|
|
(send dc set-brush pc-brk-brush)]
|
|
[(zero? frame-num)
|
|
(send dc set-pen pc-pen)
|
|
(send dc set-brush pc-brush)]
|
|
[else
|
|
(send dc set-pen pc-up-stack-pen)
|
|
(send dc set-brush pc-up-stack-brush)])
|
|
(unless (and (zero? frame-num) (cons? break-status))
|
|
;; mark the beginning of the expression with a triangle
|
|
(send dc draw-polygon (list (make-object point% xl yl)
|
|
(make-object point% xl yr)
|
|
(make-object point% xr ym)) dx dy))
|
|
(if (and (zero? frame-num) (cons? break-status))
|
|
;; top frame, end: mark the end of the expression with a triangle
|
|
(send dc draw-polygon (list (make-object point% xa ya)
|
|
(make-object point% xa yb)
|
|
(make-object point% xb ym2)) dx dy)
|
|
;; otherwise: make the end of the expression with a circle
|
|
(send dc draw-ellipse (+ xa dx) (+ ya dy yoff) diameter diameter))
|
|
(send dc set-pen op)
|
|
(send dc set-brush ob)))))))
|
|
|
|
(define/augment (after-set-next-settings s)
|
|
(let ([tlw (get-top-level-window)])
|
|
(when tlw
|
|
(send tlw check-current-language-for-debugger)))
|
|
(inner (void) after-set-next-settings s))))
|
|
|
|
;; pen and brush for drawing a breakpoint
|
|
(define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
|
;; pen and brush for marking a location that could have a breakpoint installed
|
|
(define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
|
|
(define bp-mo-brush (send the-brush-list find-or-create-brush "tomato"
|
|
'solid))
|
|
;; pen and brush for marking a conditional breakpoint
|
|
(define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
|
|
'solid))
|
|
;; pen and brush for drawing the normal execution location
|
|
(define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
|
|
;; pen and brush for marking the expression when not at the top of the stack
|
|
(define pc-up-stack-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define pc-up-stack-brush (send the-brush-list find-or-create-brush "lightgreen" 'solid))
|
|
;; pen and brush for marking the location when there's an an error
|
|
(define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
|
;; pen and brush for marking the location following a break
|
|
(define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
|
|
|
|
(define (debug-interactions-text-mixin super%)
|
|
(class super%
|
|
|
|
(inherit run-in-evaluation-thread
|
|
get-user-thread)
|
|
|
|
(super-instantiate ())
|
|
|
|
(define debugged-thread #f)
|
|
(define tab #f)
|
|
(define/public (get-tab) tab)
|
|
(define/public (set-tab t) (set! tab t))
|
|
|
|
;; Returns whether the evaluation thread has been killed.
|
|
(define/public (evaluation-thread-dead?)
|
|
(cond
|
|
[(get-user-thread) => thread-dead?]
|
|
[else #t]))
|
|
|
|
(define/override (kill-evaluation)
|
|
(super kill-evaluation)
|
|
(when (get-tab)
|
|
;; Remove any markings indicating that the program is suspended.
|
|
(send (get-tab) resume-gui)))
|
|
|
|
(define/private (stx-source->breakpoints src)
|
|
(send (send (or (and src (filename->defs src)) this) get-tab) get-breakpoints))
|
|
|
|
(define/private (stx-source->pos-vec src)
|
|
(send (send (or (and src (filename->defs src)) this) get-tab) get-pos-vec))
|
|
|
|
;; make-debug-eval-handler : (sexp -> value) -> sexp -> value
|
|
;; adds debugging information to `sexp' and calls `oe'
|
|
(define/private (make-debug-eval-handler oe break? break-before break-after)
|
|
(lambda (orig-exp)
|
|
(cond
|
|
[(compiled-expression? (if (syntax? orig-exp)
|
|
(syntax-e orig-exp)
|
|
orig-exp))
|
|
(oe orig-exp)]
|
|
[else
|
|
(define exp (if (syntax? orig-exp)
|
|
orig-exp
|
|
(namespace-syntax-introduce
|
|
(datum->syntax #f orig-exp))))
|
|
(define top-e (expand-syntax-to-top-form exp))
|
|
(define fn (and (syntax? orig-exp)
|
|
(let ([src (syntax-source orig-exp)])
|
|
(and (path? src)
|
|
src))))
|
|
(cond
|
|
[(or (eq? (filename->defs (and (syntax? orig-exp)
|
|
(syntax-source orig-exp)))
|
|
(send (get-tab) get-defs))
|
|
(annotate-this-module? fn))
|
|
(parameterize ([current-eval oe])
|
|
(eval/annotations
|
|
top-e
|
|
; annotate-module?
|
|
(lambda (fn m)
|
|
(annotate-this-module? fn))
|
|
; annotator
|
|
(lambda (stx)
|
|
(define source (syntax-source stx))
|
|
(define breakpoints (stx-source->breakpoints source))
|
|
(define pos-vec (stx-source->pos-vec source))
|
|
(define-values (annotated break-posns)
|
|
(annotate-for-single-stepping
|
|
(expand-syntax stx)
|
|
break? break-before break-after
|
|
; record-bound-identifier
|
|
(lambda (type bound binding)
|
|
(cond
|
|
[(filename->defs (robust-syntax-source bound))
|
|
=>
|
|
(lambda (defs)
|
|
(let ([pos-vec (send (send defs get-tab) get-pos-vec)])
|
|
(let loop ([i 0])
|
|
(when (< i (syntax-span bound))
|
|
(safe-vector-set! pos-vec (+ i (syntax-position bound))
|
|
binding)
|
|
(loop (add1 i))))))]
|
|
[else (void)]))
|
|
; record-top-level-identifier
|
|
(lambda (mod var rd/wr)
|
|
; filename->defs should succeed unless a slave tab gets closed
|
|
(cond
|
|
[(filename->defs (robust-syntax-source var))
|
|
=>
|
|
(lambda (defs)
|
|
(send (send defs get-tab)
|
|
add-top-level-binding var rd/wr))]
|
|
[else (void)]))
|
|
source))
|
|
(hash-for-each
|
|
breakpoints
|
|
(lambda (pos status)
|
|
; possible efficiency problem for large files with many breakpoints
|
|
(when (and (syntax-position stx)
|
|
(>= pos (syntax-position stx))
|
|
(< pos (+ (syntax-position stx) (syntax-span stx)))
|
|
(not (memq pos break-posns)))
|
|
(hash-remove! breakpoints pos))))
|
|
(for ([posn (in-list break-posns)])
|
|
(hash-set!
|
|
breakpoints posn
|
|
(hash-ref breakpoints posn (lambda () #f))))
|
|
annotated)))]
|
|
[else (oe top-e)])])))
|
|
|
|
(define/private (annotate-this-module? fn)
|
|
(cond
|
|
[(filename->defs fn)
|
|
=>
|
|
; fn is loaded into defs
|
|
(lambda (defs)
|
|
(let ([extern-tab (send defs get-tab)]
|
|
[this-tab (get-tab)])
|
|
(case (if (or (not (send extern-tab debug?))
|
|
(eq? this-tab (send extern-tab get-master)))
|
|
(message-box
|
|
"Debugging Multi-File Program"
|
|
(format "Debug ~a?" fn)
|
|
#f
|
|
'(yes-no))
|
|
(message-box
|
|
"Debugging Multi-File Program"
|
|
(format "~a is already involved in a debugging session." fn)
|
|
#f
|
|
'(ok)))
|
|
[(yes)
|
|
; set tab up with shared data from the master tab
|
|
(send extern-tab prepare-execution #t)
|
|
(send this-tab add-slave extern-tab)
|
|
(call-with-values
|
|
(lambda () (send this-tab get-shared-data))
|
|
(lambda vals (send extern-tab set-shared-data . vals)))
|
|
#t]
|
|
[(no ok)
|
|
(send extern-tab prepare-execution #f)
|
|
#f])))]
|
|
; fn is not open, so don't try to debug it
|
|
[else #f]))
|
|
|
|
(define/override (reset-console)
|
|
(super reset-console)
|
|
(let ([tab (get-tab)])
|
|
(when (and tab (send tab debug?))
|
|
(let ([breakpoints (send tab get-breakpoints)])
|
|
(run-in-evaluation-thread
|
|
(lambda ()
|
|
;(print-struct #t)
|
|
(let ([self (current-thread)]
|
|
[oeh (uncaught-exception-handler)]
|
|
[err-hndlr (error-display-handler)])
|
|
(set! debugged-thread self)
|
|
(error-display-handler
|
|
(lambda (msg exn)
|
|
(err-hndlr msg exn)
|
|
(when (and (eq? self (current-thread)) (exn:fail? exn))
|
|
(send (get-tab) suspend oeh
|
|
(continuation-mark-set->list (exn-continuation-marks exn) debug-key)
|
|
'error)))) ; this breaks the buttons because it looks like we can resume
|
|
(current-eval
|
|
(make-debug-eval-handler
|
|
(current-eval)
|
|
; break? -- curried to avoid looking up defs from source each time
|
|
(lambda (src)
|
|
(let* ([defs (filename->defs src)]
|
|
[src-tab (if defs (send defs get-tab) (get-tab))]
|
|
[breakpoints (if src
|
|
(send src-tab get-breakpoints)
|
|
breakpoints)]
|
|
[single-step? (send tab get-single-step-box)]
|
|
[closed? (send src-tab get-closed-box)])
|
|
(lambda (pos)
|
|
(and (not (unbox closed?))
|
|
(or (unbox single-step?)
|
|
(let ([bp (hash-ref breakpoints pos #f)])
|
|
(if (procedure? bp)
|
|
(bp)
|
|
bp)))))))
|
|
; break-before
|
|
(lambda (top-mark ccm)
|
|
(let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
|
|
(send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)))
|
|
; break-after
|
|
(case-lambda
|
|
[(top-mark ccm val)
|
|
(let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
|
|
(car (send (get-tab) suspend oeh (cons top-mark debug-marks)
|
|
(list 'exit-break val))))]
|
|
[(top-mark ccm . vals)
|
|
(let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
|
|
(apply values
|
|
(send (get-tab) suspend oeh (cons top-mark debug-marks)
|
|
(cons 'exit-break vals))))])))
|
|
(uncaught-exception-handler
|
|
(lambda (exn)
|
|
(if (and (exn:break? exn) (send (get-tab) suspend-on-break?))
|
|
(let ([marks (exn-continuation-marks exn)]
|
|
[cont (exn:break-continuation exn)])
|
|
(send (get-tab) suspend oeh (continuation-mark-set->list marks debug-key) 'break)
|
|
(cont))
|
|
(oeh exn)))))))))))))
|
|
|
|
(define (debug-tab-mixin super%)
|
|
(class super%
|
|
|
|
(inherit get-defs
|
|
get-ints
|
|
get-frame
|
|
is-running?)
|
|
|
|
(field [breakpoints (make-hash)]
|
|
[suspend-sema (make-semaphore 1)]
|
|
[resume-ch (make-channel)]
|
|
[in-user-ch (make-channel)]
|
|
[want-suspend-on-break? #f]
|
|
[want-debug? #f]
|
|
[master this]
|
|
[slaves empty]
|
|
[closed? (box #f)]
|
|
[stack-frames (box #f)]
|
|
[frame-num (box 0)]
|
|
[break-status (box #f)]
|
|
[current-language-settings #f]
|
|
[pos-vec (vector #f)]
|
|
[single-step? (box #t)]
|
|
[top-level-bindings empty]
|
|
[control-panel #f])
|
|
|
|
(define/public (debug?) want-debug?)
|
|
(define/public (get-master) master)
|
|
(define/public (add-slave s)
|
|
(set! slaves (cons s slaves)))
|
|
(define/public (get-closed-box) closed?)
|
|
(define/public suspend-on-break?
|
|
(case-lambda
|
|
[() want-suspend-on-break?]
|
|
[(v) (set! want-suspend-on-break? v)]))
|
|
(define/public (get-stack-frames)
|
|
(unbox stack-frames))
|
|
(define/public (get-pos-vec) pos-vec)
|
|
(define/public (get-breakpoints) breakpoints)
|
|
(define/public (get-break-status) (unbox break-status))
|
|
(define/public (get-frame-num) (unbox frame-num))
|
|
|
|
(define/public (set-shared-data bs sf sema res-ch usr-ch step? frame m)
|
|
(set! break-status bs)
|
|
(set! stack-frames sf)
|
|
(set! suspend-sema sema)
|
|
(set! resume-ch res-ch)
|
|
(set! in-user-ch usr-ch)
|
|
(set! single-step? step?)
|
|
(set! frame-num frame)
|
|
(set! master m))
|
|
|
|
(define/public (get-shared-data)
|
|
(values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? frame-num master))
|
|
|
|
(define/public (get-single-step-box) single-step?)
|
|
(define/public (set-single-step?! v) (set-box! single-step? v))
|
|
(define/public (set-break-status stat) (set-box! break-status stat))
|
|
(define/public (add-top-level-binding var rd/wr)
|
|
(set! top-level-bindings (cons (cons var rd/wr) top-level-bindings)))
|
|
(define/public (lookup-top-level-var var failure-thunk)
|
|
(let loop ([bindings top-level-bindings])
|
|
(cond
|
|
[(empty? bindings) (failure-thunk)]
|
|
[(or (bound-identifier=? var (caar bindings))
|
|
(free-identifier=? var (caar bindings))) (cdar bindings)]
|
|
[else (loop (rest bindings))])))
|
|
|
|
(define/public (move-to-frame the-frame-num)
|
|
(set-box! frame-num the-frame-num)
|
|
(suspend-gui (get-stack-frames) (get-break-status) #t #t))
|
|
|
|
(define/public (resume)
|
|
(let ([v (get-break-status)])
|
|
;; We should be suspended here, so the user thread should be waiting for a value
|
|
;; on resume-ch. However, we set a timeout to guard against cases where
|
|
;; the user thread gets interrupted or killed unexpectedly.
|
|
(when (sync/timeout 1 (channel-put-evt resume-ch (and (pair? v) (cdr v))))
|
|
(resume-gui))))
|
|
|
|
(define/public (set-mouse-over-msg msg)
|
|
(send (get-frame) set-mouse-over-msg msg))
|
|
|
|
(define/public (defs-containing-pc)
|
|
(let ([stack-frames (get-stack-frames)])
|
|
(and (cons? stack-frames)
|
|
(let* ([src-stx (mark-source (first stack-frames))]
|
|
[source (syntax-source src-stx)])
|
|
(if source
|
|
(filename->defs source)
|
|
(get-defs))))))
|
|
|
|
(define/public (defs-containing-current-frame)
|
|
(let ([stack-frames (get-stack-frames)])
|
|
(and (cons? stack-frames)
|
|
(let* ([src-stx (mark-source (list-ref stack-frames (get-frame-num)))]
|
|
[source (syntax-source src-stx)])
|
|
(if source
|
|
(filename->defs source)
|
|
(get-defs))))))
|
|
|
|
(define/public (get-pc)
|
|
(let ([stack-frames (get-stack-frames)])
|
|
(and (cons? stack-frames)
|
|
(let* ([src-stx (mark-source (first stack-frames))]
|
|
[start (syntax-position src-stx)]
|
|
[end (and start (+ start (syntax-span src-stx) -1))])
|
|
(if (cons? (get-break-status))
|
|
end
|
|
start)))))
|
|
|
|
(define/public (get-frame-endpoints frame-num)
|
|
(let ([stack-frames (get-stack-frames)])
|
|
(and (cons? stack-frames)
|
|
(let* ([src-stx (mark-source (list-ref stack-frames frame-num))]
|
|
[start (syntax-position src-stx)]
|
|
[end (and start (+ start (syntax-span src-stx) -1))])
|
|
(list start end)))))
|
|
|
|
(define/public (get-current-frame-endpoints)
|
|
(get-frame-endpoints (get-frame-num)))
|
|
|
|
(define/private (do-in-user-thread thunk)
|
|
(if (get-break-status)
|
|
;; The evaluation thread is suspended, so it should be waiting for thunks
|
|
;; to arrive on in-user-ch, evaluating them, and sending the results back
|
|
;; on result-ch. However, the user (or some background thread) might break
|
|
;; or kill the evaluation thread at any time, in which case this protocol could
|
|
;; fail. We could try to enumerate and handle all such failure modes explicitly,
|
|
;; but a simple timeout, inelegant as it may be, lets us recover from all of them.
|
|
(sync/timeout 1 (channel-put-evt in-user-ch thunk))
|
|
(send (get-ints) run-in-evaluation-thread thunk)))
|
|
|
|
;; Returns whether the user thread is free, which is the case when:
|
|
;; - it's not dead, AND either
|
|
;; * it's been suspended by the debugger, OR
|
|
;; * it's done running the user's program.
|
|
(define/private (user-thread-free?)
|
|
(and (not (send (get-ints) evaluation-thread-dead?))
|
|
(or (get-break-status) (not (is-running?)))))
|
|
|
|
(define/public (render v)
|
|
;; ==drscheme eventspace thread==
|
|
;; returns false if the user thread is unavailable to perform the rendering
|
|
(and (user-thread-free?)
|
|
(let ([result-ch (make-channel)]
|
|
[v (truncate-value v 100 5)])
|
|
(do-in-user-thread
|
|
(lambda ()
|
|
(let ([s (open-output-string)])
|
|
(send (drscheme:language-configuration:language-settings-language
|
|
current-language-settings)
|
|
render-value
|
|
v
|
|
(drscheme:language-configuration:language-settings-settings
|
|
current-language-settings)
|
|
s)
|
|
;; Set a timeout in the user thread, so we don't block forever if the
|
|
;; drscheme thread gives up waiting for our response.
|
|
(sync/timeout 1 (channel-put-evt result-ch (get-output-string s))))))
|
|
;; Set a timeout to guard against cases where the user thread
|
|
;; gets interrupted or killed in the middle of evaluation.
|
|
(sync/timeout 1 result-ch))))
|
|
|
|
(define/public (print-to-console v)
|
|
;; ==drscheme eventspace thread==
|
|
;; only when a user thread is suspended
|
|
(do-in-user-thread (lambda () (eprintf " ### DEBUGGER: ~s\n" v))))
|
|
|
|
(define/private (frame->end-breakpoint-status frame)
|
|
(let/ec k
|
|
(let* ([stx (mark-source frame)]
|
|
[src (syntax-source stx)]
|
|
[pos (if (not (syntax-position stx))
|
|
(k 'invalid)
|
|
(+ (syntax-position stx) (syntax-span stx) -1))]
|
|
[defs (filename->defs src)]
|
|
[tab (if defs (send defs get-tab) (k 'invalid))]
|
|
[bps (send tab get-breakpoints)])
|
|
(hash-ref bps pos 'invalid))))
|
|
|
|
(define/private (can-step-over? frames status)
|
|
(and (or (not (zero? (get-frame-num))) (eq? status 'entry-break))
|
|
frames
|
|
(not (empty? frames))
|
|
(not (eq? (frame->end-breakpoint-status (list-ref frames (get-frame-num))) 'invalid))))
|
|
|
|
(define/private (can-step-out? frames status)
|
|
(and frames
|
|
(let ([frames (list-tail frames (get-frame-num))])
|
|
(and (not (empty? frames))
|
|
(ormap (lambda (f) (not (eq? (frame->end-breakpoint-status f) 'invalid)))
|
|
(rest frames))))))
|
|
|
|
(define/public suspend-gui
|
|
(lambda (frames status [switch-tabs? #f] [already-stopped? #f])
|
|
(let ([top-of-stack? (zero? (get-frame-num))]
|
|
[status-message (send (get-frame) get-status-message)])
|
|
(set! want-suspend-on-break? #f)
|
|
(set-single-step?! #f)
|
|
(set-box! stack-frames frames)
|
|
(set-box! break-status status)
|
|
(send (send (get-frame) get-pause-button) enable #f)
|
|
(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-out-button) enable (can-step-out? frames status))
|
|
(send (send (get-frame) get-resume-button) enable #t)
|
|
(when (cons? frames)
|
|
(send (get-frame) register-stack-frames frames already-stopped?)
|
|
(send (get-frame) register-vars (list-ref frames (get-frame-num))))
|
|
(send status-message set-label
|
|
(if (and (cons? status) top-of-stack?)
|
|
(let ([expr (mark-source (first frames))])
|
|
(cond
|
|
; should succeed unless the user closes a slave tab during debugging
|
|
[(filename->defs (syntax-source expr))
|
|
=> (lambda (defs)
|
|
(clean-status
|
|
(string-append
|
|
(if (syntax-position expr)
|
|
(trim-expr-str
|
|
(send defs get-text
|
|
(sub1 (syntax-position expr))
|
|
(+ -1 (syntax-position expr) (syntax-span expr))))
|
|
"??")
|
|
" => "
|
|
(if (= 2 (length status))
|
|
(render (cadr status))
|
|
(string-append
|
|
"(values"
|
|
(let loop ([vals (rest status)])
|
|
(cond
|
|
[(cons? vals) (string-append " " (render (first vals))
|
|
(loop (rest vals)))]
|
|
[else ")"])))))))]
|
|
[""]))
|
|
""))
|
|
(cond [(get-current-frame-endpoints)
|
|
=> (lambda (start/end)
|
|
(cond [(and (first start/end) (defs-containing-current-frame))
|
|
=> (lambda (defs)
|
|
(cond
|
|
[(and switch-tabs? (send defs get-filename))
|
|
=> (lambda (fn) (handler:edit-file fn))])
|
|
(send defs scroll-to-position (first start/end)))]))])
|
|
(send (get-defs) invalidate-bitmap-cache))))
|
|
|
|
(define/public (resume-gui)
|
|
(set-box! stack-frames #f)
|
|
(set-box! break-status #f)
|
|
(set-box! frame-num 0)
|
|
(send (send (get-frame) get-pause-button) enable #t)
|
|
(send (send (get-frame) get-step-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-resume-button) enable #f)
|
|
(send (send (get-frame) get-status-message) set-label "")
|
|
(send (get-frame) clear-stack-frames/vars)
|
|
(send (get-defs) invalidate-bitmap-cache))
|
|
|
|
(define/public suspend
|
|
;; ==called from user thread==
|
|
(lambda (break-handler frames [status #f])
|
|
;; suspend-sema ensures that we allow only one suspended thread
|
|
;; at a time
|
|
(cond
|
|
[(semaphore-try-wait? suspend-sema)
|
|
(parameterize ([current-eventspace (send (get-frame) get-eventspace)])
|
|
(queue-callback (lambda () (suspend-gui frames status #t))))
|
|
(with-handlers ([exn:break?
|
|
(lambda (exn)
|
|
(let ([wait-sema (make-semaphore)])
|
|
(parameterize ([current-eventspace (send (get-frame) get-eventspace)])
|
|
(queue-callback (lambda ()
|
|
(resume-gui)
|
|
(semaphore-post wait-sema))))
|
|
(semaphore-wait wait-sema))
|
|
(semaphore-post suspend-sema)
|
|
(break-handler exn))])
|
|
(begin0
|
|
(let loop ()
|
|
(sync/enable-break
|
|
resume-ch (handle-evt in-user-ch (lambda (thunk)
|
|
(thunk)
|
|
(loop)))))
|
|
(semaphore-post suspend-sema)))]
|
|
[(pair? status) (cdr status)]
|
|
[else #f])))
|
|
|
|
(define/public (prepare-execution debug?)
|
|
(set! want-debug? debug?)
|
|
(cond
|
|
[debug? (send (get-frame) show-debug)]
|
|
[else (send (get-frame) hide-debug)
|
|
(set! master this)
|
|
(for-each (lambda (t) (send t prepare-execution #f)) slaves)
|
|
(set! slaves empty)])
|
|
(set! current-language-settings (and debug? (send (get-defs) get-next-settings)))
|
|
(set! single-step? (box #t))
|
|
(set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f))
|
|
(set! top-level-bindings empty)
|
|
(set! resume-ch (make-channel))
|
|
(set! suspend-sema (make-semaphore 1))
|
|
(set! in-user-ch (make-channel))
|
|
(set! break-status (box #f))
|
|
(set! want-suspend-on-break? #f)
|
|
(set! stack-frames (box #f))
|
|
(send (get-ints) set-tab this))
|
|
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(set-box! closed? #t)
|
|
(for-each (lambda (t) (send t prepare-execution #f)) slaves))
|
|
|
|
(define/public (hide-debug)
|
|
(send (get-frame) hide-debug))
|
|
|
|
(super-new)))
|
|
|
|
;; define icons for the tool and debug panel
|
|
(define debug-bitmap (compiled-bitmap (debugger-icon)))
|
|
(define small-debug-bitmap (compiled-bitmap (small-debugger-icon)))
|
|
(define over-bitmap
|
|
(compiled-bitmap
|
|
(pict->bitmap
|
|
(cc-superimpose (bitmap (text-icon "()" #:color syntax-icon-color))
|
|
(bitmap (right-over-arrow-icon #:color run-icon-color))))))
|
|
(define out-bitmap
|
|
(compiled-bitmap
|
|
(pict->bitmap
|
|
(hc-append
|
|
-8
|
|
(bitmap (text-icon "()" #:color syntax-icon-color))
|
|
(bitmap (right-arrow-icon #:color run-icon-color #:height 19))))))
|
|
|
|
(define pause-bitmap (compiled-bitmap (pause-icon #:color run-icon-color)))
|
|
(define resume-bitmap (compiled-bitmap (play-icon #:color run-icon-color)))
|
|
(define step-bitmap (compiled-bitmap (step-icon #:color run-icon-color)))
|
|
|
|
(define make-pause-label (bitmap-label-maker "Pause" pause-bitmap))
|
|
(define make-resume-label (bitmap-label-maker "Go" resume-bitmap))
|
|
(define make-step-label (bitmap-label-maker "Step" step-bitmap))
|
|
(define make-over-label (bitmap-label-maker "Over" over-bitmap))
|
|
(define make-out-label (bitmap-label-maker "Out" out-bitmap))
|
|
|
|
(define (debug-unit-frame-mixin super%)
|
|
(class super%
|
|
|
|
(inherit get-button-panel
|
|
get-definitions-text
|
|
get-interactions-text
|
|
get-menu-bar
|
|
get-current-tab
|
|
get-top-level-window
|
|
get-eventspace)
|
|
|
|
(define current-language-settings #f)
|
|
(define control-panel #f)
|
|
(define debug? #f)
|
|
(define/public (set-mouse-over-msg msg)
|
|
(when (not (string=? msg (send mouse-over-message get-label)))
|
|
(send mouse-over-message set-label msg)))
|
|
|
|
(define/public (debug-callback)
|
|
(let ([tab (get-current-tab)])
|
|
(cond
|
|
[(eq? tab (send tab get-master))
|
|
(set! debug? #t)
|
|
(execute-callback)
|
|
(set! debug? #f)]
|
|
[else
|
|
(already-debugging tab)])))
|
|
|
|
(define/override (execute-callback)
|
|
(let ([tab (get-current-tab)])
|
|
(cond
|
|
[(eq? tab (send tab get-master))
|
|
(send (get-current-tab) prepare-execution debug?)
|
|
(super execute-callback)]
|
|
[else
|
|
(already-debugging tab)])))
|
|
|
|
(define/private (already-debugging tab)
|
|
(message-box
|
|
"Debugger"
|
|
(format "This file is involved in a debugging session. To run/debug this file, finish the session for ~a and close or re-run it."
|
|
(send (send (send tab get-master) get-defs) get-filename/untitled-name))
|
|
this '(ok)))
|
|
|
|
(define expr-positions empty)
|
|
(define expr-lengths empty)
|
|
|
|
(define/public (register-vars frame)
|
|
(send variables-text begin-edit-sequence)
|
|
(send variables-text lock #f)
|
|
(send variables-text delete 0 (send variables-text last-position))
|
|
(for-each
|
|
(lambda (name/value)
|
|
(let ([name (format "~a" (syntax-e (first name/value)))]
|
|
[value (format " => ~s\n" (truncate-value (second name/value) 100 5))])
|
|
(send variables-text insert name)
|
|
(send variables-text change-style bold-sd
|
|
(- (send variables-text last-position) (string-length name))
|
|
(send variables-text last-position))
|
|
(send variables-text insert value)
|
|
(send variables-text change-style normal-sd
|
|
(- (send variables-text last-position) (string-length value))
|
|
(send variables-text last-position))))
|
|
(third (expose-mark frame)))
|
|
(send variables-text lock #t)
|
|
(send variables-text end-edit-sequence))
|
|
|
|
(define/public (register-stack-frames frames already-stopped?)
|
|
(let* ([trimmed-exprs
|
|
(map (lambda (frame)
|
|
(let ([expr (mark-source frame)])
|
|
(cond
|
|
; should succeed unless the user closes a slave tab during debugging
|
|
[(and expr (filename->defs (syntax-source expr)))
|
|
=> (lambda (defs)
|
|
(trim-expr-str
|
|
(if (syntax-position expr)
|
|
(send defs get-text
|
|
(sub1 (syntax-position expr))
|
|
(+ -1 (syntax-position expr) (syntax-span expr)))
|
|
"??")
|
|
15))]
|
|
["??"])))
|
|
frames)]
|
|
[trimmed-lengths (map add1 (map string-length trimmed-exprs))]
|
|
[positions (foldl + 0 trimmed-lengths)])
|
|
(send stack-frames begin-edit-sequence)
|
|
(send stack-frames lock #f)
|
|
(unless already-stopped?
|
|
(send stack-frames delete 0 (send stack-frames last-position))
|
|
(for-each (lambda (trimmed-expr)
|
|
(send stack-frames insert (format "~a\n" trimmed-expr)))
|
|
trimmed-exprs))
|
|
(send stack-frames change-style normal-sd 0 (send stack-frames last-position))
|
|
(send stack-frames change-style bold-sd
|
|
(send stack-frames paragraph-start-position (send (get-current-tab) get-frame-num))
|
|
(send stack-frames paragraph-end-position (send (get-current-tab) get-frame-num)))
|
|
(send stack-frames lock #t)
|
|
(send stack-frames end-edit-sequence)))
|
|
|
|
(define/public (clear-stack-frames/vars)
|
|
(send stack-frames begin-edit-sequence)
|
|
(send stack-frames lock #f)
|
|
(send stack-frames delete 0 (send stack-frames last-position))
|
|
(send stack-frames lock #t)
|
|
(send stack-frames end-edit-sequence)
|
|
(send variables-text begin-edit-sequence)
|
|
(send variables-text lock #f)
|
|
(send variables-text delete 0 (send variables-text last-position))
|
|
(send variables-text lock #t)
|
|
(send variables-text end-edit-sequence))
|
|
|
|
(define debug-grandparent-panel 'uninitialized-debug-grandparent-panel)
|
|
(define debug-parent-panel 'uninitialized-debug-parent-panel)
|
|
(define debug-panel 'uninitialized-debug-panel)
|
|
(define stack-view-panel 'uninitialized-stack-view-panel)
|
|
(define stack-frames 'uninitialized-stack-frames)
|
|
(define variables-text 'uninitialized-variables-text)
|
|
(define highlight-color (make-object color% 207 255 207))
|
|
(define bold-sd (make-object style-delta% 'change-weight 'bold))
|
|
(define normal-sd (make-object style-delta% 'change-weight 'normal))
|
|
(define mouse-over-frame #f)
|
|
(define/override (get-definitions/interactions-panel-parent)
|
|
(set! debug-grandparent-panel
|
|
(new (class panel:horizontal-dragable%
|
|
(inherit get-percentages)
|
|
(define/augment (get-default-percentages i)
|
|
(cond
|
|
[(= i 2)
|
|
(define p (preferences:get 'plt:debug-tool:stack/variable-area))
|
|
(list p (- 1 p))]
|
|
[else (build-list i (λ (x) (/ i)))]))
|
|
(define/augment (after-percentage-change)
|
|
(define ps (get-percentages))
|
|
(when (= (length ps) 2)
|
|
(preferences:set 'plt:debug-tool:stack/variable-area (car ps)))
|
|
(inner (void) after-percentage-change))
|
|
(super-new))
|
|
[parent (super get-definitions/interactions-panel-parent)]))
|
|
(set! stack-view-panel
|
|
(new panel:vertical-dragable%
|
|
[parent debug-grandparent-panel]
|
|
[min-width 160]
|
|
[stretchable-width #f]))
|
|
(set! stack-frames
|
|
(new (class text%
|
|
(super-new)
|
|
(inherit find-line line-start-position line-end-position
|
|
change-style begin-edit-sequence end-edit-sequence
|
|
lock last-position line-paragraph find-position
|
|
dc-location-to-editor-location)
|
|
(define highlight-defs #f)
|
|
(define highlight-start #f)
|
|
(define highlight-end #f)
|
|
(define mouse-over-frame #f)
|
|
(define/override (on-event evt)
|
|
(let*-values ([(x y) (dc-location-to-editor-location
|
|
(send evt get-x) (send evt get-y))]
|
|
[(line) (find-line y)]
|
|
[(pos) (find-position x y)]
|
|
[(paragraph) (line-paragraph line)]
|
|
[(frames) (send (get-current-tab) get-stack-frames)]
|
|
[(frame) (and frames
|
|
(> (length frames) paragraph)
|
|
(list-ref frames paragraph))]
|
|
[(expr) (and frame (mark-source frame))])
|
|
(case (send evt get-event-type)
|
|
[(enter motion)
|
|
(when (and mouse-over-frame (not (= paragraph mouse-over-frame)))
|
|
;; motion to different frame: unhighlight old
|
|
(send highlight-defs unhighlight-range
|
|
highlight-start highlight-end highlight-color)
|
|
(set! mouse-over-frame #f))
|
|
(when (and expr (not (eq? mouse-over-frame paragraph)))
|
|
;; motion to frame: highlight new
|
|
(cond
|
|
[(filename->defs (syntax-source expr))
|
|
=> (lambda (defs)
|
|
(set! mouse-over-frame paragraph)
|
|
(set! highlight-defs defs)
|
|
(set! highlight-start (sub1 (syntax-position expr)))
|
|
(set! highlight-end (+ -1 (syntax-position expr)
|
|
(syntax-span expr)))
|
|
(send defs highlight-range
|
|
highlight-start highlight-end highlight-color)
|
|
(cond
|
|
[(send defs get-filename)
|
|
=> (lambda (fn) (handler:edit-file fn))])
|
|
(send defs scroll-to-position (syntax-position expr)))]))]
|
|
[(leave)
|
|
(when mouse-over-frame
|
|
;; motion to different frame: unhighlight old
|
|
(send highlight-defs unhighlight-range
|
|
highlight-start highlight-end highlight-color)
|
|
(set! mouse-over-frame #f))
|
|
(cond
|
|
[(send (get-current-tab) get-frame-num)
|
|
=> (lambda (num) (send (get-current-tab) move-to-frame num))])]
|
|
[(left-down)
|
|
(when (and paragraph expr)
|
|
(send (get-current-tab) move-to-frame paragraph))]
|
|
[else (void)]))))))
|
|
(set! variables-text (new text% [auto-wrap #f]))
|
|
(let ([stack-frames-panel (make-object vertical-panel% stack-view-panel)])
|
|
(new message% [parent stack-frames-panel] [label "Stack"])
|
|
(new editor-canvas% [parent stack-frames-panel] [editor stack-frames] [style '(no-hscroll)]))
|
|
(let ([variables-panel (make-object vertical-panel% stack-view-panel)])
|
|
(new message% [parent variables-panel] [label "Variables"])
|
|
(new editor-canvas% [parent variables-panel] [editor variables-text] [style '(no-hscroll)]))
|
|
;; 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% ()
|
|
(parent debug-parent-panel)
|
|
(stretchable-height #f)
|
|
(alignment '(center center))
|
|
(style '(border))))
|
|
;; add a close button to the debug panel
|
|
(new close-icon%
|
|
[parent debug-panel]
|
|
[callback (λ () (send (get-current-tab) break-callback)
|
|
(hide-debug))])
|
|
;; hide the debug panel and stack view initially
|
|
(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))
|
|
|
|
(define/public (hide-debug)
|
|
(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
|
|
(lambda (l) (remq debug-panel l)))))
|
|
|
|
(define/public (show-debug)
|
|
(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
|
|
(lambda (l) (cons debug-panel l)))))
|
|
|
|
(super-new)
|
|
|
|
(define status-message
|
|
(instantiate message% ()
|
|
[label " "]
|
|
[parent debug-panel]
|
|
[stretchable-width #t]))
|
|
|
|
(define debug-button
|
|
(new switchable-button%
|
|
(label (string-constant debug-tool-button-name))
|
|
(bitmap debug-bitmap)
|
|
(alternate-bitmap small-debug-bitmap)
|
|
(parent (new panel:horizontal-discrete-sizes%
|
|
[parent (get-button-panel)]
|
|
[alignment '(center center)]))
|
|
(callback (λ (button) (debug-callback)))))
|
|
(inherit register-toolbar-button)
|
|
(register-toolbar-button debug-button #:number 60)
|
|
|
|
(define/augment (enable-evaluation)
|
|
(send debug-button enable #t)
|
|
(inner (void) enable-evaluation))
|
|
|
|
(define/augment (disable-evaluation)
|
|
(send debug-button enable #f)
|
|
(inner (void) disable-evaluation))
|
|
|
|
(define pause-button
|
|
(instantiate button% ()
|
|
[label (make-pause-label this)]
|
|
[parent debug-panel]
|
|
[callback (lambda (button evt)
|
|
(cond [(send (get-current-tab) get-stack-frames) (bell)]
|
|
[else (send (get-current-tab) suspend-on-break? #t)
|
|
(send (get-current-tab) break-callback)
|
|
(send (get-current-tab) reset-offer-kill)]))]
|
|
[enabled #t]))
|
|
|
|
(define resume-button
|
|
(instantiate button% ()
|
|
[label (make-resume-label this)]
|
|
[parent debug-panel]
|
|
[callback (lambda (button evt)
|
|
(if (send (get-current-tab) get-stack-frames)
|
|
(send (get-current-tab) resume)
|
|
(bell)))]
|
|
[enabled #f]))
|
|
|
|
(define step-button
|
|
(instantiate button% ()
|
|
[label (make-step-label this)]
|
|
[parent debug-panel]
|
|
[callback (lambda (btn evt)
|
|
(cond [(send (get-current-tab) get-stack-frames)
|
|
(send (get-current-tab) set-single-step?! #t)
|
|
(send (get-current-tab) resume)]
|
|
[else (bell)]))]
|
|
[enabled #f]))
|
|
|
|
(define (make-big-step-callback out?)
|
|
(lambda (btn evt)
|
|
; go through stack frames until it's possible to set a breakpoint at the end
|
|
(let* ([frames (list-tail (send (get-current-tab) get-stack-frames)
|
|
(send (get-current-tab) get-frame-num))]
|
|
[frames (case (send (get-current-tab) get-break-status)
|
|
[(entry-break) (if out? (rest frames) frames)]
|
|
[else (if out? (rest frames) empty)])]
|
|
[frame (ormap (lambda (f depth)
|
|
(let/ec k
|
|
(let* ([stx (mark-source f)]
|
|
[src (syntax-source stx)]
|
|
[lpos (or (syntax-position stx) (k #f))]
|
|
[pos (+ lpos (syntax-span stx) -1)]
|
|
[defs (filename->defs src)]
|
|
[tab (if defs (send defs get-tab) (k #f))]
|
|
[bps (send tab get-breakpoints)]
|
|
[cur-stat (hash-ref bps pos 'invalid)])
|
|
(case cur-stat
|
|
[(invalid) #f]
|
|
[else
|
|
(hash-set!
|
|
bps pos
|
|
(lambda ()
|
|
(and (< (length (continuation-mark-set->list
|
|
(current-continuation-marks) debug-key)) depth)
|
|
(begin
|
|
(hash-set! bps pos cur-stat)
|
|
#t))))
|
|
f]))))
|
|
frames
|
|
(let ([len (length frames)])
|
|
(build-list len (lambda (i) (- len i)))))])
|
|
(cond [frames (send (get-current-tab) set-single-step?! (not frame))
|
|
(send (get-current-tab) resume)]
|
|
[else (bell)]))))
|
|
|
|
(define step-over-button
|
|
(new button%
|
|
[label (make-over-label this)]
|
|
[parent debug-panel]
|
|
[callback (make-big-step-callback #f)]
|
|
[enabled #f]))
|
|
|
|
(define step-out-button
|
|
(new button%
|
|
[label (make-out-label this)]
|
|
[parent debug-panel]
|
|
[callback (make-big-step-callback #t)]
|
|
[enabled #f]))
|
|
|
|
(define/public (get-debug-button) debug-button)
|
|
(define/public (get-pause-button) pause-button)
|
|
(define/public (get-resume-button) resume-button)
|
|
(define/public (get-step-button) step-button)
|
|
(define/public (get-step-over-button) step-over-button)
|
|
(define/public (get-step-out-button) step-out-button)
|
|
(define/public (get-status-message) status-message)
|
|
|
|
(define mouse-over-message
|
|
(instantiate message% ()
|
|
[label " "] [parent debug-panel] [stretchable-width #t]))
|
|
|
|
(define/augment (on-tab-change old new)
|
|
(check-current-language-for-debugger)
|
|
(if (send new debug?)
|
|
(let ([status (send new get-break-status)])
|
|
(if status
|
|
(send new suspend-gui (send new get-stack-frames) status #f #t)
|
|
(send new resume-gui))
|
|
(show-debug))
|
|
(hide-debug))
|
|
(inner (void) on-tab-change old new))
|
|
|
|
(define/public (check-current-language-for-debugger)
|
|
(let* ([settings (send (get-definitions-text) get-next-settings)]
|
|
[lang (drscheme:language-configuration:language-settings-language settings)]
|
|
[visible? (and (send lang capability-value 'gui-debugger:debug-button)
|
|
(not (is-a? lang drscheme:module-language:module-language<%>)) ;; the opt-out button handles this language
|
|
(not (debugger-does-not-work-for?
|
|
(extract-language-level settings))))])
|
|
(if visible?
|
|
(unless (send debug-button is-shown?)
|
|
(send (send debug-button get-parent) add-child debug-button))
|
|
(when (send debug-button is-shown?)
|
|
(send (send debug-button get-parent) delete-child debug-button)))))
|
|
|
|
(send (get-button-panel) change-children
|
|
(lambda (children)
|
|
(cons (send debug-button get-parent)
|
|
(remq (send debug-button get-parent) children))))
|
|
|
|
; hide debug button if it's not supported for the initial language:
|
|
(check-current-language-for-debugger)))
|
|
(drscheme:language:register-capability 'gui-debugger:debug-button (flat-contract boolean?) #t)
|
|
(drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin)
|
|
(drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin)
|
|
(drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin)
|
|
(drscheme:get/extend:extend-tab debug-tab-mixin)))
|