#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/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)
      (and (< idx (vector-length vec)) (vector-ref vec idx)))
    
    (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])
        (and (< i (string-length str))
             (if (char=? chr (string-ref str i))
                 i
                 (loop (add1 i))))))
    
    (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 str [len 10])
      (define strlen (string-length str))
      (define starts-with-paren (and (positive? strlen) (char=? (string-ref str 0) #\()))
      (define len2 (+ len 4))
      (define 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) "...")]
        [(and (bytes? v)
              (> (bytes-length v) size))
         (bytes-append (subbytes v 0 size) #"...")]
        [(list? v)
         (define len (length v))
         (define 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 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)
            (define breakpoints (send (get-tab) get-breakpoints))
            (define 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)
            (define breakpoints (send (get-tab) get-breakpoints))
            (define 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)
          (define event-x (send event get-x))
          (define event-y (send event get-y))
          (define on-it? (box #f))
          (let loop ([editor this])
            (define-values (x y) (send editor dc-location-to-editor-location event-x event-y))
            (cond
              [(is-a? editor text%)
               (define 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%)
               (define 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))
          (define xlb (box 0))
          (define ylb (box 0))
          (define xrb (box 0))
          (define yrb (box 0))
          (send text position-location start-pos xlb ylb #t)
          (send text position-location end-pos xrb yrb #f)
          (define-values (xl-off yl-off)
            (send text editor-location-to-dc-location (unbox xlb) (unbox ylb)))
          (define-values (xl yl) (dc-location-to-editor-location xl-off yl-off))
          (define-values (xr-off yr-off)
            (send text editor-location-to-dc-location (unbox xrb) (unbox yrb)))
          (define-values (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)]
            ;; 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)
            [else (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)
          (define frames (send (get-tab) get-stack-frames))
          (define pos-vec (send (get-tab) get-pos-vec))
          (define id (robust-vector-ref pos-vec pos))
          (unless (lookup-var
                   id
                   frames
                   (lambda (val wr)
                     (define id-sym (syntax-e id))
                     (define 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)
                        (define 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)
          (define 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)])
            (cond
              [(and pc (= pos pc))
               (define stat (send (get-tab) get-break-status))
               (get-top-level-window)
               (define 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)))))
               (unless (eq? stat 'break)
                 (make-object
                  menu-item%
                  (if (cons? stat) "Change return value..." "Skip expression...")
                  menu
                  (lambda (item evt)
                    (define 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))))))]
              [else
               (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 '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)
          (define 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 '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)])
                   (define frames (send (get-tab) get-stack-frames))
                   (define pos-vec (send (get-tab) get-pos-vec))
                   (define 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.
                   (define 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))))
                   (define-values (xl yl xr yr) (find-char-box this pos))
                   (define diameter (- xr xl))
                   (define yoff (/ (- yr yl diameter) 2))
                   (define op (send dc get-pen))
                   (define 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
            (define frame-defs (send (get-tab) defs-containing-current-frame))
            (define pos (send (get-tab) get-current-frame-endpoints))
            (define start (and pos (first pos)))
            (define end (and pos (second pos)))
            (define frame-num (send (get-tab) get-frame-num))
            (define break-status (send (get-tab) get-break-status))
            (when (and (eq? frame-defs this) start end)
              (define-values (xl yl xr yr) (find-char-box this start))
              (define ym (average yl yr))
              (define-values (xa ya xb yb) (find-char-box this end))
              (define diameter (- xb xa))
              (define yoff (/ (- yb ya diameter) 2))
              (define ym2 (average ya yb))
              (define op (send dc get-pen))
              (define 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 system-eventspace (current-eventspace))

    (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))))
               (define annotating-tabs (make-hasheq))
               (cond
                 [(or (eq? (filename->defs (and (syntax? orig-exp)
                                                (syntax-source orig-exp)))
                           (send (get-tab) get-defs))
                      (annotate-this-module? fn annotating-tabs))
                  (parameterize ([current-eval oe])
                   (eval/annotations
                    top-e
                    ; annotate-module?
                    (lambda (fn m) 
                      (annotate-this-module? fn annotating-tabs))
                    ; 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 secondary 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 #f)))
                      annotated)))]
                 [else (oe top-e)])])))
        
        (define/private (annotate-this-module? fn annotating-tabs)
          ;; ==called from user thread==
          (define result-ch (make-channel))
          (parameterize ([current-eventspace system-eventspace])
            (queue-callback
             (lambda ()
               ;; ==drscheme eventspace thread==
               (cond
                 [(filename->defs fn)
                  =>
                  ; fn is loaded into defs
                  (lambda (defs)
                    (define extern-tab (send defs get-tab))
                    (define this-tab (get-tab))
                    (define frame (send this-tab get-frame))
                    (hash-ref
                     annotating-tabs
                     extern-tab
                     (lambda ()
                       (define extern-debug?
                         (eq? 'yes
                              (if (or (not (send extern-tab debug?))
                                      (eq? this-tab (send extern-tab get-primary)))
                                  (message-box "Debugging Multi-File Program"
                                               (format "Debug ~a?" fn)
                                               frame
                                               '(yes-no))
                                  (message-box
                                   "Debugging Multi-File Program"
                                   (format "~a is already involved in a debugging session." fn)
                                   frame
                                   '(ok)))))
                       (hash-set! annotating-tabs extern-tab extern-debug?)
                       (cond
                         [extern-debug?
                          ;; set tab up with shared data from the primary tab
                          (send this-tab add-secondary extern-tab)
                          (send extern-tab prepare-execution #t #f)
                          (call-with-values (lambda () (send this-tab get-shared-data))
                                            (lambda vals (send extern-tab set-shared-data . vals)))]
                         [else
                          ;; leave `extern-tab` alone, unless it was previously
                          ;; tied to this tab:
                          (when (eq? this-tab (send extern-tab get-primary))
                            (send extern-tab prepare-execution #f #f))])
                       (channel-put result-ch extern-debug?))))]
                 ; fn is not open, so don't try to debug it
                 [else (channel-put result-ch #f)]))))
          (channel-get result-ch))
        
        (define/override (reset-console)
          (super reset-console)
          (let ([tab (get-tab)])
            (when (and tab (send tab debug?))
              (define 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)
                       (define 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)
                        (define 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]
               [primary this]
               [secondaries 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-primary) primary)
        (define/public (add-secondary s)
          (set! secondaries (cons s secondaries)))
        (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 p)
          (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! primary p))
        
        (define/public (get-shared-data)
          (values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? frame-num primary))
        
        (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)
          (define 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 ()
               (define 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 secondary 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? [to-front? #t])
          (set! want-debug? debug?)
          (cond
            [debug? (send (get-frame) show-debug)]
            [else (when to-front?
                    (send (get-frame) hide-debug))
                  (set! primary this)
                  (for-each (lambda (t) (send t prepare-execution #f #f)) secondaries)
                  (set! secondaries 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))
          (when to-front?
            (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 #f)) secondaries))
        
        (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 (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)
          (unless (string=? msg (send mouse-over-message get-label))
            (send mouse-over-message set-label msg)))
        
        (define/public (debug-callback)
          (define tab (get-current-tab))
          (cond
            [(eq? tab (send tab get-primary))
             (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-primary))
               (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+ tab (get-primary) (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) 88 4))])
               (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 secondary 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:foreground-color-mixin
                             (editor:standard-style-list-mixin text:basic%))
                       (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:foreground-color-mixin
                                     (editor:standard-style-list-mixin text:basic%))
                                    [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 canvas:color% [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 canvas:color% [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
          (new switchable-button%
               [label "Pause"]
               [bitmap pause-bitmap]
               [alternate-bitmap pause-bitmap]
               [parent debug-panel]
               [callback (λ _
                           (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)]))]
               [min-width-includes-label? #t]
               [enabled #t]))
        
        (define resume-button
          (new switchable-button%
               [label "Go"]
               [bitmap resume-bitmap]
               [alternate-bitmap resume-bitmap]
               [parent debug-panel]
               [callback (λ _
                           (if (send (get-current-tab) get-stack-frames)
                               (send (get-current-tab) resume)
                               (bell)))]
               [min-width-includes-label? #t]
               [enabled #f]))
        (send resume-button set-label-visible #t)
        
        (define step-button
          (new switchable-button%
               [label "Step"]
               [bitmap step-bitmap]
               [alternate-bitmap step-bitmap]
               [parent debug-panel]
               [callback (λ _
                           (cond [(send (get-current-tab) get-stack-frames)
                                  (send (get-current-tab) set-single-step?! #t)
                                  (send (get-current-tab) resume)]
                                 [else (bell)]))]
               [min-width-includes-label? #t]
               [enabled #f]))
        
        (define (make-big-step-callback out?)
          (λ _
            ; 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 switchable-button%
               [label "Over"]
               [bitmap over-bitmap]
               [alternate-bitmap over-bitmap]
               [parent debug-panel]
               [callback (make-big-step-callback #f)]
               [min-width-includes-label? #t]
               [enabled #f]))
        
        (define step-out-button
          (new switchable-button%
               [label "Out"]
               [bitmap out-bitmap]
               [alternate-bitmap out-bitmap]
               [parent debug-panel]
               [callback (make-big-step-callback #t)]
               [min-width-includes-label? #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
          (new 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))))])
            (define debug-parent (send debug-button get-parent))
            (define debug-button-currently-visible? (member debug-button (send debug-parent get-children)))
            (if visible?
                (unless debug-button-currently-visible?
                  (send debug-parent add-child debug-button))
                (when debug-button-currently-visible?
                  (send debug-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)))
