#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
         framework
         (for-syntax racket/base
                     racket/class
                     racket/draw
                     images/icons/arrow
                     images/icons/control
                     images/icons/style
                     images/icons/symbol
                     images/icons/tool
                     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)))))
       'debug-tool
       #:number 60)
      (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 ignore-modification? #f)
        (define/augment (begin-metadata-changes)
          (inner (void) begin-metadata-changes)
          (set! ignore-modification? #t))
        (define/augment (end-metadata-changes)
          (inner (void) end-metadata-changes)
          (set! ignore-modification? #f))
        
        (define/augment (on-delete start len)
          (unless ignore-modification?
            (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)
          (unless ignore-modification?
            (when (send (get-tab) debug?)
              (send (get-tab) hide-debug))
            (end-edit-sequence)))
        
        (define/augment (on-insert start len)
          (inner (void) on-insert start len)
          (unless ignore-modification?
            (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))))
        
        (define/augment (after-insert start len)
          (inner (void) after-insert start len)
          (unless ignore-modification?
            (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))
                                        (or (render (cadr status)) "??")
                                        (string-append
                                         "(values"
                                         (let loop ([vals (rest status)])
                                           (cond
                                             [(cons? vals) (string-append " "
                                                                          (or (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-pane% stack-view-panel)])
            (new editor:font-size-message% [parent stack-frames-panel] [message "Stack"])
            (new editor-canvas% [parent stack-frames-panel] [editor stack-frames] [style '(auto-hscroll)]))
          (let ([variables-panel (make-object vertical-pane% stack-view-panel)])
            (new editor:font-size-message% [parent variables-panel] [message "Variables"])
            (new editor-canvas% [parent variables-panel] [editor variables-text] [style '(auto-hscroll)]))
          ;; parent of panel with debug buttons
          (set! debug-parent-panel
                (make-object vertical-pane% 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-pane% 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)))