(module debug-tool mzscheme (require mzlib/etc mzlib/list mzlib/class mzlib/unit mzlib/contract mred mzlib/match drscheme/tool "marks.ss" mrlib/switchable-button mrlib/bitmap-label "annotator.ss" "load-sandbox.ss" framework string-constants lang/debugger-language-interface) (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 tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define (phase1) (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... ;; (
) => () ;; ( ... ) => ( ...) (define trim-expr-str (opt-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)))))] [else v])) (define filename->defs (opt-lambda (source [default #f]) (let/cc 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) ;; 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)) (super-instantiate ()) (define/augment (on-delete start len) (begin-edit-sequence) (let ([breakpoints (send (get-tab) get-breakpoints)] [shifts empty]) (hash-table-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-table-remove! breakpoints pos)] ; deletion before breakpoint: shift breakpoint [(> pos (+ start len)) (hash-table-remove! breakpoints pos) (set! shifts (cons (cons (- pos len) status) shifts))]))) (for-each (lambda (p) (hash-table-put! 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-table-for-each breakpoints (lambda (pos status) (when (< start pos) ;; text inserted before this breakpoint, so shift ;; the breakpoint forward by positions (hash-table-remove! breakpoints pos) (set! shifts (cons (cons (+ pos len) status) shifts))))) ;; update the breakpoint locations (for-each (lambda (p) (hash-table-put! 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 (lookup-var id frames sk fk) (cond [(and id frames (lookup-first-binding (lambda (id2) (module-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 end -> (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 left-pos right-pos) (let ([xlb (box 0)] [ylb (box 0)] [xrb (box 0)] [yrb (box 0)]) (send text position-location left-pos xlb ylb #t) (send text position-location right-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)]) (values xl yl xr yr)))) (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 (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 (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-table-put! 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-table-put! breakpoints pos (lambda () (hash-table-put! 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 (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-table-get 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 (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-table-get 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)]) (send (get-tab) set-mouse-over-msg (clean-status (lookup-var id (list-tail frames (send (get-tab) get-frame-num)) ;; id found (lambda (val _) (string-append (symbol->string (syntax-e id)) " = " (render val))) ;; id not found (lambda () "")))))))) (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-table-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 (sub1 pos) 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 (sub1 start) start)] [(ym) (average yl yr)] [(xa ya xb yb) (find-char-box this (sub1 end) 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)))) (define (debug-interactions-text-mixin super%) (class super% (inherit run-in-evaluation-thread) (super-instantiate ()) (define debugged-thread #f) (define tab #f) (define/public (get-tab) tab) (define/public (set-tab t) (set! tab t)) (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) (if (compiled-expression? (if (syntax? orig-exp) (syntax-e orig-exp) orig-exp)) (oe orig-exp) (let* ([exp (if (syntax? orig-exp) orig-exp (namespace-syntax-introduce (datum->syntax-object #f orig-exp)))] [top-e (expand-syntax-to-top-form exp)]) (parameterize ([current-eval oe]) (eval/annotations top-e ; annotate-module? (lambda (fn m) (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])) ; annotator (lambda (stx) (let*-values ([(source) (syntax-source stx)] [(breakpoints) (stx-source->breakpoints source)] [(pos-vec) (stx-source->pos-vec source)] [(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-table-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-table-remove! breakpoints pos)))) (for-each (lambda (posn) (hash-table-put! breakpoints posn (hash-table-get breakpoints posn (lambda () #f)))) break-posns) annotated)))))))) (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) (if (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-table-get 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) (field [breakpoints (make-hash-table)] [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)]) (resume-gui) (channel-put resume-ch (and (pair? v) (cdr v))))) (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 (do-in-user-thread thunk) (if (get-break-status) (channel-put in-user-ch thunk) (send (get-ints) run-in-evaluation-thread thunk))) (define/public (render v) ;; ==drscheme eventspace thread== ;; only when a user thread is suspended (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) (channel-put result-ch (get-output-string s))))) (channel-get result-ch))) (define/public (print-to-console v) ;; ==drscheme eventspace thread== ;; only when a user thread is suspended (do-in-user-thread (lambda () (fprintf (current-error-port) " ### DEBUGGER: ~s~n" v)))) (define (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-table-get bps pos 'invalid)))) (define (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 (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 (opt-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== (opt-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 debug-bitmap (make-object bitmap% (build-path (collection-path "gui-debugger" "icons") "clanbomber-16x16.png") 'png/mask)) (define make-pause-label (bitmap-label-maker "Pause" (build-path (collection-path "gui-debugger" "icons") "pause.png"))) (define make-resume-label (bitmap-label-maker "Go" (build-path (collection-path "gui-debugger" "icons") "resume.png"))) (define make-step-label (bitmap-label-maker "Step" (build-path (collection-path "gui-debugger" "icons") "step.png"))) (define make-over-label (bitmap-label-maker "Over" (build-path (collection-path "gui-debugger" "icons") "step-over2.png"))) (define make-out-label (bitmap-label-maker "Out" (build-path (collection-path "gui-debugger" "icons") "step-out2.png"))) (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" (second name/value))]) (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 (make-object horizontal-panel% (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 #t])) (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)))) ;; 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) (parent (new vertical-pane% [parent (get-button-panel)] [alignment '(center center)])) (callback (λ (button) (debug-callback))))) (inherit register-toolbar-button) (register-toolbar-button debug-button) (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-table-get bps pos 'invalid)]) (case cur-stat [(invalid) #f] [else (hash-table-put! bps pos (lambda () (and (< (length (continuation-mark-set->list (current-continuation-marks) debug-key)) depth) (begin (hash-table-put! 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 (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 (_) (cons (send debug-button get-parent) (remq (send debug-button get-parent) _)))) ; 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))))