(module debug-tool mzscheme
  (require mzlib/etc
           mzlib/list
           mzlib/class
           mzlib/unit
           mzlib/contract
           mred
           mzlib/match
           drscheme/tool
           "marks.ss"
           mrlib/switchable-button
           mrlib/bitmap-label
           "annotator.ss"
           "load-sandbox.ss"
           framework
           string-constants
           lang/debugger-language-interface)
  
  (provide tool@)
  
  ; QUESTIONS/IDEAS
  ; what is the right way to deal with macros?
  ; how can the three tool classes communicate with each other safely
  
  (define-local-member-name debug-callback)
  
  (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)
                (parent parent)
                (callback (λ (button) (send frame debug-callback)))))
         'macro-stepper)
	(drscheme:language:extend-language-interface
         debugger-language<%>
         (lambda (superclass)
           (class* superclass (debugger-language<%>)
	           (public debugger:supported?)
		   (define (debugger:supported?) #t)
                   (super-instantiate ())))))
      (define phase2 void)
      
      (define (extract-language-level settings)
	(drscheme:language-configuration:language-settings-language settings))
      
      (define (debugger-does-not-work-for? lang)
	(not (send lang debugger:supported?)))
      
      (define (robust-syntax-source stx)
        (and (syntax? stx) (syntax-source stx)))
      
      (define (robust-vector-ref vec idx)
        (if (< idx (vector-length vec))
            (vector-ref vec idx)
            #f))
      
      (define (safe-vector-set! vec idx val)
        (when (< idx (vector-length vec))
          (vector-set! vec idx val))
        (void))
      
      (define (truncate str n)
        (cond [(< (string-length str) n) str]
              [(>= n 3) (string-append
                          (substring str 0 (- n 3))
                          "...")]
              [else (substring str 0 (min n (string-length str)))]))
      
      (define (clean-status s)
	(truncate (regexp-replace* #rx"\n" s " ") 200))
      
      (define (index-of chr str)
        (let loop ([i 0])
          (if (< i (string-length str))
              (if (char=? chr (string-ref str i))
                  i
                  (loop (add1 i)))
              #f)))
      
      (define (safe-min . args)
        (apply min (filter identity args)))
      
      ;; trim-expr-str: string -> string
      ;; examples:
      ;; short-id                   => short-id
      ;; really-long-identifier     => really-lon...
      ;; (<form>)                   => (<form>)
      ;; (<form> <arg1> ... <argn>) => (<form> ...)
      (define trim-expr-str
        (opt-lambda (str [len 10])
          (let* ([strlen (string-length str)]
                 [starts-with-paren (and (> strlen 0)
                                         (char=? (string-ref str 0) #\())]
                 [len2 (+ len 4)]
                 [trunc-pos (safe-min (index-of #\space str)
                                      (index-of #\newline str)
                                      (and (> strlen len2) len)
                                      strlen)])
            (if (>= trunc-pos strlen)
                str
                (string-append
                 (substring str 0 trunc-pos)
                 (if starts-with-paren
                     " ...)"
                     " ..."))))))
      
      (define (average . values)
        (/ (apply + values) (length values)))
      
      (define (truncate-value v size depth)
        (cond
          [(zero? depth) '...]
          [(and (string? v)
                (> (string-length v) size))
           (string-append (substring v 0 size) "...")]
          [(list? v)
           (let* ([len (length v)]
                  [res (build-list (min size len)
                                   (lambda (i) (truncate-value (list-ref v i) size (sub1 depth))))])
             (if (> len size) (append res (list '...)) res))]
          [(vector? v)
           (build-vector (min size (vector-length v))
                         (lambda (i)
                           (if (and (= i (sub1 size))
                                    (> size (vector-length v)))
                               '...
                               (truncate-value (vector-ref v i) size (sub1 depth)))))]
          [else v]))
      
      (define filename->defs
        (opt-lambda (source [default #f])
          (let/cc k
            (cond
              [(is-a? source editor<%>) source]
              [else
               (send (group:get-the-frame-group) for-each-frame
                     (lambda (frame)
                       (and (is-a? frame drscheme:unit:frame<%>)
                            (let* ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))]
                                   [defs (findf (lambda (d) (send d port-name-matches? source)) defss)])
                              (and defs (k defs))))))
               default]))))
      
      (define (debug-definitions-text-mixin super%)
        (class super%
          
          (inherit dc-location-to-editor-location
                   editor-location-to-dc-location
                   invalidate-bitmap-cache
                   begin-edit-sequence
                   end-edit-sequence
                   get-canvas
                   get-top-level-window
                   get-filename
                   get-tab)
          
          (define mouse-over-pos #f)
          ;; pen and brush for drawing a breakpoint
          (define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
          ;; pen and brush for marking a location that could have a breakpoint installed
          (define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
          (define bp-mo-brush (send the-brush-list find-or-create-brush "tomato"
                                    'solid))
          ;; pen and brush for marking a conditional breakpoint
          (define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
                                     'solid))
          ;; pen and brush for drawing the normal execution location
          (define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
          ;; pen and brush for marking the expression when not at the top of the stack
          (define pc-up-stack-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define pc-up-stack-brush (send the-brush-list find-or-create-brush "lightgreen" 'solid))
          ;; pen and brush for marking the location when there's an an error
          (define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
          ;; pen and brush for marking the location following a break
          (define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
          
          (super-instantiate ())
          
          (define/augment (on-delete start len)
            (begin-edit-sequence)
            (let ([breakpoints (send (get-tab) get-breakpoints)]
                  [shifts empty])
              (hash-table-for-each
               breakpoints
               (lambda (pos status)
                 (cond
                   ; deletion after breakpoint: no effect
                   [(<= pos start)]
                   ; deletion of breakpoint: remove from table
                   [(and (< start pos)
                         (<= pos (+ start len)))
                    (hash-table-remove! breakpoints pos)]
                   ; deletion before breakpoint: shift breakpoint
                   [(> pos (+ start len))
                    (hash-table-remove! breakpoints pos)
                    (set! shifts (cons (cons (- pos len) status) shifts))])))
              (for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p)))
                        shifts))
            (inner (void) on-delete start len))
          
          (define/augment (after-delete start len)
            (inner (void) after-delete start len)
            (when (send (get-tab) debug?)
              (send (get-tab) hide-debug))
            (end-edit-sequence))
          
          (define/augment (on-insert start len)
            (begin-edit-sequence)
            (let ([breakpoints (send (get-tab) get-breakpoints)]
                  [shifts empty])
              (hash-table-for-each
               breakpoints
               (lambda (pos status)
                 (when (< start pos)
                   ;; text inserted before this breakpoint, so shift
                   ;; the breakpoint forward by <len> positions
                   (hash-table-remove! breakpoints pos)
                   (set! shifts (cons (cons (+ pos len) status) shifts)))))
              ;; update the breakpoint locations
              (for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p)))
                        shifts))
            (inner (void) on-insert start len))
          
          (define/augment (after-insert start len)
            (inner (void) after-insert start len)
            (when (send (get-tab) debug?)
              (send (get-tab) hide-debug))
            (end-edit-sequence))
          
          ;; lookup id in the given set of stack frames;
          ;; if that fails, try the top-level environment
          ;; invokes sk on success, fk on failure
          (define (lookup-var id frames sk fk)
            (cond
              [(and id frames (lookup-first-binding
                               (lambda (id2) (module-identifier=? id id2))
                               frames (lambda () #f)))
               => (lambda (binding)
                    (sk (mark-binding-value binding)
                        (lambda (v) (mark-binding-set! binding v))))]
              [(and id (send (get-tab) lookup-top-level-var
                             id (lambda () #f)))
               => (lambda (tlb)
                    (sk (tlb) tlb))]
              [else (fk)]))
          
          ;; mouse-event -> (or (values #f #f) (values pos editor))
          (define/private (get-pos/text event)
            (let ([event-x (send event get-x)]
                  [event-y (send event get-y)]
                  [on-it? (box #f)])
              (let loop ([editor this])
                (let-values ([(x y) (send editor dc-location-to-editor-location
                                          event-x event-y)])
                  (cond
                    [(is-a? editor text%)
                     (let ([pos (send editor find-position x y #f on-it?)])
                       (cond
                         [(not (unbox on-it?)) (values #f #f)]
                         [else
                          (let ([snip (send editor find-snip pos 'after-or-none)])
                            (if (and snip
                                     (is-a? snip editor-snip%))
                                (loop (send snip get-editor))
                                (values pos editor)))]))]
                    [(is-a? editor pasteboard%)
                     (let ([snip (send editor find-snip x y)])
                       (if (and snip
                                (is-a? snip editor-snip%))
                           (loop (send snip get-editor))
                           (values #f #f)))]
                    [else (values #f #f)])))))
          
          ;; text% start end -> (values left top right bottom)
          ;; (four numbers that indicate the locations in pixels of the
          ;;  box bounding the text between start and end
          (define/private (find-char-box text left-pos right-pos)
            (let ([xlb (box 0)]
                  [ylb (box 0)]
                  [xrb (box 0)]
                  [yrb (box 0)])
              (send text position-location left-pos xlb ylb #t)
              (send text position-location right-pos xrb yrb #f)
              (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
                                                   (unbox xlb) (unbox ylb))]
                            [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
                            [(xr-off yr-off) (send text editor-location-to-dc-location
                                                   (unbox xrb) (unbox yrb))]
                            [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
                (values xl yl xr yr))))
          
          (define/private (render v)
            (send (get-tab) render v))
          
          ;; mouse-event% integer -> ()
          ;; handles a right-click on a position that's not a breakable paren
          (define (debugger-handle-right-click-non-breakable event pos)
            (let* ([frames (send (get-tab) get-stack-frames)]
                   [pos-vec (send (get-tab) get-pos-vec)]
                   [id (robust-vector-ref pos-vec pos)])
              (unless (lookup-var
                       id frames
                       (lambda (val wr)
                         (let ([id-sym (syntax-e id)]
                               [menu (make-object popup-menu% #f)])
                           (make-object menu-item%
                             (clean-status (format "Print value of ~a to console" id-sym))
                             menu
                             (lambda (item evt)
                               (send (get-tab) print-to-console (format "~a = ~s" id-sym val))))
                           (make-object menu-item% (format "(set! ~a ...)" id-sym) menu
                             (lambda (item evt)
                               (let* ([tmp (get-text-from-user
                                            (format "New value for ~a" id-sym) #f #f
                                            (format "~a" val))])
                                 (when tmp
                                   (let/ec k
                                     (wr (with-handlers
                                             ([exn:fail?
                                               (lambda (exn)
                                                 (message-box
                                                  "Debugger Error"
                                                  (format "The following error occurred: ~a"
                                                          (exn-message exn)))
                                                 (k))])
                                           (read (open-input-string tmp)))))))))
                           (send (get-canvas) popup-menu menu
                                 (+ 1 (inexact->exact (floor (send event get-x))))
                                 (+ 1 (inexact->exact (floor (send event get-y)))))
                           #t))
                       (lambda () #f))
                (super on-event event))))
          
          (define (debugger-handle-right-click-breakable event breakpoints pos break-status)
            (let ([menu (make-object popup-menu% #f)])
              (make-object menu-item%
                (if break-status
                    "Remove pause at this point"
                    "Pause at this point")
                menu
                (lambda (item evt)
                  (hash-table-put! breakpoints pos (not break-status))
                  (invalidate-bitmap-cache)))
              (let ([pc (send (get-tab) get-pc)])
                (if (and pc (= pos pc))
                    (let* ([stat (send (get-tab) get-break-status)]
                           [f (get-top-level-window)]
                           [rendered-value
                            (if (cons? stat)
                                (if (= 2 (length stat))
                                    (render (cadr stat))
                                    (format "~s" (cons 'values 
                                                       (map (lambda (v) (render v)) (rest stat)))))
                                "")])
                      (when (cons? stat)
                        (make-object menu-item%
                          "Print return value to console" menu
                          (lambda _ (send (get-tab) print-to-console
                                          (string-append "return val = " rendered-value)))))
                      (when (not (eq? stat 'break))
                        (make-object menu-item%
                          (if (cons? stat)
                              "Change return value..."
                              "Skip expression...")
                          menu
                          (lambda (item evt)
                            (let ([tmp (get-text-from-user "Return value" #f)])
                              (when tmp
                                (let/ec k
                                  (send (get-tab) set-break-status
                                        (cons 'exit-break
                                              (call-with-values
                                               (lambda ()
                                                 (with-handlers
                                                     ([exn:fail?
                                                       (lambda (exn)
                                                         (message-box
                                                          "Debugger Error"
                                                          (format "An error occurred: ~a" (exn-message exn))
                                                          #f '(ok))
                                                         (k))])
                                                   (read (open-input-string tmp))))
                                               list)))
                                  (invalidate-bitmap-cache))))))))
                    (make-object menu-item%
                      "Continue to this point"
                      menu
                      (lambda (item evt)
                        (hash-table-put!
                         breakpoints pos
                         (lambda () (hash-table-put! breakpoints pos break-status) #t))
                        (invalidate-bitmap-cache)
                        (when (send (get-tab) get-stack-frames)
                          (send (get-tab) resume))))))
              (send (get-canvas) popup-menu menu
                    (+ 1 (inexact->exact (floor (send event get-x))))
                    (+ 1 (inexact->exact (floor (send event get-y)))))))
          
          (define (debugger-handle-right-click event breakpoints)
            (let-values ([(pos text) (get-pos/text event)])
              (if (and pos text)
                  (let* ([pos (add1 pos)]
                         [break-status (hash-table-get breakpoints pos (lambda () 'invalid))])
                    (match break-status
                      [(or #t #f (? procedure?))
                       (debugger-handle-right-click-breakable event breakpoints pos break-status)]
                      ['invalid
                       (debugger-handle-right-click-non-breakable event pos)]))
                  (super on-event event))))
          
          (define (debugger-handle-event event)
            (let ([breakpoints (send (get-tab) get-breakpoints)])
              (cond
                [(send event leaving?)
                 (when mouse-over-pos
                   (set! mouse-over-pos #f)
                   (invalidate-bitmap-cache))
                 (super on-event event)]
                [(or (send event moving?)
                     (send event entering?))
                 (let-values ([(pos text) (get-pos/text event)])
                   (when (and pos text)
                     (let ([pos (add1 pos)])
                       (cond
                         ;; mouse on breakable pos and hasn't moved significantly
                         [(eq? pos mouse-over-pos)]
                         ;; mouse on new breakable pos
                         [(not (eq? (hash-table-get
                                     breakpoints pos (lambda () 'invalid)) 'invalid))
                          (set! mouse-over-pos pos)
                          (invalidate-bitmap-cache)]
                         ;; moved off breakable pos
                         [mouse-over-pos
                          (set! mouse-over-pos #f)
                          (invalidate-bitmap-cache)])
                       (let* ([frames (send (get-tab) get-stack-frames)]
                              [pos-vec (send (get-tab) get-pos-vec)]
                              [id (robust-vector-ref pos-vec pos)]
                              ;; 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-table-for-each
                 breakpoints
                 (lambda (pos enabled?)
                   (when (and (>= pos 0) (or enabled? (and mouse-over-pos (= mouse-over-pos pos))))
                     (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
                                   [(diameter) (- xr xl)]
                                   [(yoff) (/ (- yr yl diameter) 2)])
                       (let ([op (send dc get-pen)]
                             [ob (send dc get-brush)])
                         (case enabled?
                           [(#t) (send dc set-pen bp-pen)
                                 (send dc set-brush bp-brush)]
                           [(#f) (send dc set-pen bp-mo-pen)
                                 (send dc set-brush bp-mo-brush)]
                           [else (send dc set-pen bp-tmp-pen)
                                 (send dc set-brush bp-tmp-brush)])
                         (send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
                         (send dc set-pen op)
                         (send dc set-brush ob)))))))
              ;; mark the boundaries of the current stack frame
              ;; unless we're at the end of the expression and looking at the top frame,
              ;; in which case just mark the current location
              (let* ([frame-defs (send (get-tab) defs-containing-current-frame)]
                     [pos (send (get-tab) get-current-frame-endpoints)]
                     [start (and pos (first pos))]
                     [end (and pos (second pos))]
                     [frame-num (send (get-tab) get-frame-num)]
                     [break-status (send (get-tab) get-break-status)])
                (when (and (eq? frame-defs this) start end)
                  (let*-values ([(xl yl xr yr) (find-char-box this (sub1 start) start)]
                                [(ym) (average yl yr)]
                                [(xa ya xb yb) (find-char-box this (sub1 end) end)]
                                [(diameter) (- xb xa)]
                                [(yoff) (/ (- yb ya diameter) 2)]
                                [(ym2) (average ya yb)])
                    (let ([op (send dc get-pen)]
                          [ob (send dc get-brush)])
                      (cond
                        [(and (zero? frame-num)
                              (eq? break-status 'error))
                         (send dc set-pen pc-err-pen)
                         (send dc set-brush pc-err-brush)]
                        [(and (zero? frame-num)
                              (eq? break-status 'break))
                         (send dc set-pen pc-brk-pen)
                         (send dc set-brush pc-brk-brush)]
                        [(zero? frame-num)
                         (send dc set-pen pc-pen)
                         (send dc set-brush pc-brush)]
                        [else
                         (send dc set-pen pc-up-stack-pen)
                         (send dc set-brush pc-up-stack-brush)])
                      (unless (and (zero? frame-num) (cons? break-status))
                        ;; mark the beginning of the expression with a triangle
                        (send dc draw-polygon (list (make-object point% xl yl)
                                                    (make-object point% xl yr)
                                                    (make-object point% xr ym)) dx dy))
                      (if (and (zero? frame-num) (cons? break-status))
                          ;; top frame, end: mark the end of the expression with a triangle
                          (send dc draw-polygon (list (make-object point% xa ya)
                                                      (make-object point% xa yb)
                                                      (make-object point% xb ym2)) dx dy)
                          ;; otherwise: make the end of the expression with a circle
                          (send dc draw-ellipse (+ xa dx) (+ ya dy yoff) diameter diameter))
                      (send dc set-pen op)
                      (send dc set-brush ob)))))))
          
          (define/augment (after-set-next-settings s)
            (let ([tlw (get-top-level-window)])
              (when tlw
                (send tlw check-current-language-for-debugger)))
            (inner (void) after-set-next-settings s))))
      
      (define (debug-interactions-text-mixin super%)
        (class super%
          
          (inherit run-in-evaluation-thread
                   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)
              (if (compiled-expression? (if (syntax? orig-exp)
                                            (syntax-e orig-exp)
                                            orig-exp))
                  (oe orig-exp)
                  (let* ([exp (if (syntax? orig-exp)
                                  orig-exp
                                  (namespace-syntax-introduce
                                   (datum->syntax-object #f orig-exp)))]
                         [top-e (expand-syntax-to-top-form exp)])
                    (parameterize ([current-eval oe])
                      (eval/annotations
                       top-e
                       ; annotate-module?
                       (lambda (fn m)
                         (cond
                           [(filename->defs fn)
                            =>
                            ; fn is loaded into defs
                            (lambda (defs)
                              (let ([extern-tab (send defs get-tab)]
                                    [this-tab (get-tab)])
                                (case (if (or (not (send extern-tab debug?))
                                              (eq? this-tab (send extern-tab get-master)))
                                          (message-box
                                           "Debugging Multi-File Program"
                                           (format "Debug ~a?" fn)
                                           #f
                                           '(yes-no))
                                          (message-box
                                           "Debugging Multi-File Program"
                                           (format "~a is already involved in a debugging session." fn)
                                           #f
                                           '(ok)))
                                  [(yes)
                                   ; set tab up with shared data from the master tab
                                   (send extern-tab prepare-execution #t)
                                   (send this-tab add-slave extern-tab)
                                   (call-with-values
                                    (lambda () (send this-tab get-shared-data))
                                    (lambda vals (send extern-tab set-shared-data . vals)))
                                   #t]
                                  [(no ok)
                                   (send extern-tab prepare-execution #f)
                                   #f])))]
                           ; fn is not open, so don't try to debug it
                           [else #f]))
                       ; annotator
                       (lambda (stx)
                         (let*-values ([(source) (syntax-source stx)]
                                       [(breakpoints) (stx-source->breakpoints source)]
                                       [(pos-vec) (stx-source->pos-vec source)]
                                       [(annotated break-posns)
                                        (annotate-for-single-stepping
                                         (expand-syntax stx)
                                         break? break-before break-after
                                         ; record-bound-identifier
                                         (lambda (type bound binding)
                                           (cond
                                             [(filename->defs (robust-syntax-source bound))
                                              =>
                                              (lambda (defs)
                                                (let ([pos-vec (send (send defs get-tab) get-pos-vec)])
                                                  (let loop ([i 0])
                                                    (when (< i (syntax-span bound))
                                                      (safe-vector-set! pos-vec (+ i (syntax-position bound))
                                                                        binding)
                                                   (loop (add1 i))))))]
                                             [else (void)]))
                                         ; record-top-level-identifier
                                         (lambda (mod var rd/wr)
                                           ; filename->defs should succeed unless a slave tab gets closed
                                           (cond
                                             [(filename->defs (robust-syntax-source var))
                                              =>
                                              (lambda (defs)
                                                (send (send defs get-tab)
                                                      add-top-level-binding var rd/wr))]
                                             [else (void)]))
                                         source)])
                           (hash-table-for-each
                            breakpoints
                            (lambda (pos status)
                              ; possible efficiency problem for large files with many breakpoints
                              (when (and (syntax-position stx)
                                         (>= pos (syntax-position stx))
                                         (< pos (+ (syntax-position stx) (syntax-span stx)))
                                         (not (memq pos break-posns)))
                                (hash-table-remove! breakpoints pos))))
                           (for-each (lambda (posn)
                                       (hash-table-put!
                                        breakpoints posn
                                        (hash-table-get breakpoints posn (lambda () #f)))) break-posns)
                           annotated))))))))
          
          (define/override (reset-console)
            (super reset-console)
            (let ([tab (get-tab)])
              (when (and tab (send tab debug?))
                (let ([breakpoints (send tab get-breakpoints)])
                  (run-in-evaluation-thread
                   (lambda ()
                     ;(print-struct #t)
                     (let ([self (current-thread)]
                           [oeh (uncaught-exception-handler)]
                           [err-hndlr (error-display-handler)])
                       (set! debugged-thread self)
                       (error-display-handler
                        (lambda (msg exn)
                          (err-hndlr msg exn)
                          (if (and (eq? self (current-thread)) (exn:fail? exn))
                              (send (get-tab) suspend oeh
                                    (continuation-mark-set->list (exn-continuation-marks exn) debug-key)
                                    'error)))) ; this breaks the buttons because it looks like we can resume
                       (current-eval
                        (make-debug-eval-handler
                         (current-eval)
                         ; break? -- curried to avoid looking up defs from source each time
                         (lambda (src)
                           (let* ([defs (filename->defs src)]
                                  [src-tab (if defs (send defs get-tab) (get-tab))]
                                  [breakpoints (if src
                                                   (send src-tab get-breakpoints)
                                                   breakpoints)]
                                  [single-step? (send tab get-single-step-box)]
                                  [closed? (send src-tab get-closed-box)])
                             (lambda (pos)
                               (and (not (unbox closed?))
                                    (or (unbox single-step?)
                                        (let ([bp (hash-table-get breakpoints pos #f)])
                                          (if (procedure? bp)
                                              (bp)
                                              bp)))))))
                         ; break-before
                         (lambda (top-mark ccm)
                           (let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
                             (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)))
                         ; break-after
                         (case-lambda
                           [(top-mark ccm val)
                            (let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
                              (car (send (get-tab) suspend oeh (cons top-mark debug-marks)
                                         (list 'exit-break val))))]
                           [(top-mark ccm . vals) 
                            (let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
                              (apply values
                                     (send (get-tab) suspend oeh (cons top-mark debug-marks)
                                           (cons 'exit-break vals))))])))
                       (uncaught-exception-handler
                        (lambda (exn)
                          (if (and (exn:break? exn) (send (get-tab) suspend-on-break?))
                              (let ([marks (exn-continuation-marks exn)]
                                    [cont (exn:break-continuation exn)])
                                (send (get-tab) suspend oeh (continuation-mark-set->list marks debug-key) 'break)
                                (cont))
                              (oeh exn)))))))))))))
      
      (define (debug-tab-mixin super%)
        (class super%
          
          (inherit get-defs
                   get-ints
                   get-frame
                   is-running?)
          
          (field [breakpoints (make-hash-table)]
                 [suspend-sema (make-semaphore 1)]
                 [resume-ch (make-channel)]
                 [in-user-ch (make-channel)]
                 [want-suspend-on-break? #f]
                 [want-debug? #f]
                 [master this]
                 [slaves empty]
                 [closed? (box #f)]
                 [stack-frames (box #f)]
                 [frame-num (box 0)]
                 [break-status (box #f)]
                 [current-language-settings #f]
                 [pos-vec (vector #f)]
                 [single-step? (box #t)]
                 [top-level-bindings empty]
                 [control-panel #f])
          
          (define/public (debug?) want-debug?)
          (define/public (get-master) master)
          (define/public (add-slave s)
            (set! slaves (cons s slaves)))
          (define/public (get-closed-box) closed?)
          (define/public suspend-on-break?
            (case-lambda
              [() want-suspend-on-break?]
              [(v) (set! want-suspend-on-break? v)]))
          (define/public (get-stack-frames)
            (unbox stack-frames))
          (define/public (get-pos-vec) pos-vec)
          (define/public (get-breakpoints) breakpoints)
          (define/public (get-break-status) (unbox break-status))
          (define/public (get-frame-num) (unbox frame-num))
          
          (define/public (set-shared-data bs sf sema res-ch usr-ch step? frame m)
            (set! break-status bs)
            (set! stack-frames sf)
            (set! suspend-sema sema)
            (set! resume-ch res-ch)
            (set! in-user-ch usr-ch)
            (set! single-step? step?)
            (set! frame-num frame)
            (set! master m))
          
          (define/public (get-shared-data)
            (values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? frame-num master))
          
          (define/public (get-single-step-box) single-step?)
          (define/public (set-single-step?! v) (set-box! single-step? v))
          (define/public (set-break-status stat) (set-box! break-status stat))
          (define/public (add-top-level-binding var rd/wr)
            (set! top-level-bindings (cons (cons var rd/wr) top-level-bindings)))
          (define/public (lookup-top-level-var var failure-thunk)
            (let loop ([bindings top-level-bindings])
              (cond
                [(empty? bindings) (failure-thunk)]
                [(or (bound-identifier=? var (caar bindings))
                     (free-identifier=? var (caar bindings))) (cdar bindings)]
                [else (loop (rest bindings))])))
          
          (define/public (move-to-frame the-frame-num)
            (set-box! frame-num the-frame-num)
            (suspend-gui (get-stack-frames) (get-break-status) #t #t))
          
          (define/public (resume)
            (let ([v (get-break-status)])
              ;; 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 (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 () (fprintf (current-error-port) " ### DEBUGGER: ~s\n" v))))
          
          (define (frame->end-breakpoint-status frame)
            (let/ec k
              (let* ([stx (mark-source frame)]
                     [src (syntax-source stx)]
                     [pos (if (not (syntax-position stx))
                              (k 'invalid)
                              (+ (syntax-position stx) (syntax-span stx) -1))]
                     [defs (filename->defs src)]
                     [tab (if defs (send defs get-tab) (k 'invalid))]
                     [bps (send tab get-breakpoints)])
                (hash-table-get bps pos 'invalid))))
          
          (define (can-step-over? frames status)
            (and (or (not (zero? (get-frame-num))) (eq? status 'entry-break))
                 frames
                 (not (empty? frames))
                 (not (eq? (frame->end-breakpoint-status (list-ref frames (get-frame-num))) 'invalid))))
          
          (define (can-step-out? frames status)
            (and frames
              (let ([frames (list-tail frames (get-frame-num))])
                (and (not (empty? frames))
                     (ormap (lambda (f) (not (eq? (frame->end-breakpoint-status f) 'invalid)))
                            (rest frames))))))

          (define/public suspend-gui
            (opt-lambda (frames status [switch-tabs? #f] [already-stopped? #f])
              (let ([top-of-stack? (zero? (get-frame-num))]
                    [status-message (send (get-frame) get-status-message)])
                (set! want-suspend-on-break? #f)
                (set-single-step?! #f)
                (set-box! stack-frames frames)
                (set-box! break-status status)
                (send (send (get-frame) get-pause-button) enable #f)
                (send (send (get-frame) get-step-button) enable top-of-stack?)
                (send (send (get-frame) get-step-over-button) enable (can-step-over? frames status))
                (send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
                (send (send (get-frame) get-resume-button) enable #t)
                (when (cons? frames)
                  (send (get-frame) register-stack-frames frames already-stopped?)
                  (send (get-frame) register-vars (list-ref frames (get-frame-num))))
                (send status-message set-label
                      (if (and (cons? status) top-of-stack?)
                          (let ([expr (mark-source (first frames))])
                            (cond
                              ; should succeed unless the user closes a slave tab during debugging
                              [(filename->defs (syntax-source expr))
                               => (lambda (defs)
                                    (clean-status
                                     (string-append
                                      (if (syntax-position expr)
                                          (trim-expr-str
                                           (send defs get-text
                                                 (sub1 (syntax-position expr))
                                                 (+ -1 (syntax-position expr) (syntax-span expr))))
                                          "??")
                                      " => "
                                      (if (= 2 (length status))
                                          (render (cadr status))
                                          (string-append
                                           "(values"
                                           (let loop ([vals (rest status)])
                                             (cond
                                               [(cons? vals) (string-append " " (render (first vals))
                                                                            (loop (rest vals)))]
                                               [else ")"])))))))]
                              [""]))
                          ""))
                (cond [(get-current-frame-endpoints)
                       => (lambda (start/end)
                            (cond [(and (first start/end) (defs-containing-current-frame))
                                   => (lambda (defs)
                                        (cond
                                          [(and switch-tabs? (send defs get-filename))
                                           => (lambda (fn) (handler:edit-file fn))])
                                        (send defs scroll-to-position (first start/end)))]))])
                (send (get-defs) invalidate-bitmap-cache))))
          
          (define/public (resume-gui)
            (set-box! stack-frames #f)
            (set-box! break-status #f)
            (set-box! frame-num 0)
            (send (send (get-frame) get-pause-button) enable #t)
            (send (send (get-frame) get-step-button) enable #f)
            (send (send (get-frame) get-step-over-button) enable #f)
            (send (send (get-frame) get-step-out-button) enable #f)
            (send (send (get-frame) get-resume-button) enable #f)
            (send (send (get-frame) get-status-message) set-label "")
            (send (get-frame) clear-stack-frames/vars)
            (send (get-defs) invalidate-bitmap-cache))
          
          (define/public suspend
            ;; ==called from user thread==
            (opt-lambda (break-handler frames [status #f])
              ;; suspend-sema ensures that we allow only one suspended thread
              ;;  at a time
              (cond
                [(semaphore-try-wait? suspend-sema)
                 (parameterize ([current-eventspace (send (get-frame) get-eventspace)])
                   (queue-callback (lambda () (suspend-gui frames status #t))))
                 (with-handlers ([exn:break?
                                  (lambda (exn)
                                    (let ([wait-sema (make-semaphore)])
                                      (parameterize ([current-eventspace (send (get-frame) get-eventspace)])
                                        (queue-callback (lambda () 
                                                          (resume-gui)
                                                          (semaphore-post wait-sema))))
                                      (semaphore-wait wait-sema))
                                    (semaphore-post suspend-sema)
                                    (break-handler exn))])
                   (begin0
                     (let loop ()
                       (sync/enable-break
                        resume-ch (handle-evt in-user-ch (lambda (thunk)
                                                           (thunk)
                                                           (loop)))))
                     (semaphore-post suspend-sema)))]
                [(pair? status) (cdr status)]
                [else #f])))
          
          (define/public (prepare-execution debug?)
            (set! want-debug? debug?)
            (cond
              [debug? (send (get-frame) show-debug)]
              [else (send (get-frame) hide-debug)
                    (set! master this)
                    (for-each (lambda (t) (send t prepare-execution #f)) slaves)
                    (set! slaves empty)])
            (set! current-language-settings (and debug? (send (get-defs) get-next-settings)))
            (set! single-step? (box #t))
            (set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f))
            (set! top-level-bindings empty)
            (set! resume-ch (make-channel))
            (set! suspend-sema (make-semaphore 1))
            (set! in-user-ch (make-channel))
            (set! break-status (box #f))
            (set! want-suspend-on-break? #f)
            (set! stack-frames (box #f))
            (send (get-ints) set-tab this))
          
          (define/augment (on-close)
            (inner (void) on-close)
            (set-box! closed? #t)
            (for-each (lambda (t) (send t prepare-execution #f)) slaves))
          
          (define/public (hide-debug)
            (send (get-frame) hide-debug))
          
          (super-new)))
      
      (define debug-bitmap 
        (make-object bitmap%
          (build-path (collection-path "gui-debugger" "icons") "clanbomber-16x16.png")
          'png/mask))
      
      (define make-pause-label
        (bitmap-label-maker
         "Pause"
         (build-path (collection-path "gui-debugger" "icons") "pause.png")))
      (define make-resume-label 
        (bitmap-label-maker
         "Go"
         (build-path (collection-path "gui-debugger" "icons") "resume.png")))
      (define make-step-label
        (bitmap-label-maker
         "Step"
         (build-path (collection-path "gui-debugger" "icons") "step.png")))
      (define make-over-label
        (bitmap-label-maker
         "Over"
         (build-path (collection-path "gui-debugger" "icons") "step-over2.png")))
      (define make-out-label
        (bitmap-label-maker
         "Out"
         (build-path (collection-path "gui-debugger" "icons") "step-out2.png")))
      
      (define (debug-unit-frame-mixin super%)
        (class super%
          
          (inherit get-button-panel
                   get-definitions-text
                   get-interactions-text
                   get-menu-bar
                   get-current-tab
                   get-top-level-window
                   get-eventspace)
          
          (define current-language-settings #f)
          (define control-panel #f)
          (define debug? #f)
          (define/public (set-mouse-over-msg msg)
            (when (not (string=? msg (send mouse-over-message get-label)))
              (send mouse-over-message set-label msg)))
          
          (define/public (debug-callback)
            (let ([tab (get-current-tab)])
              (cond
                [(eq? tab (send tab get-master))
                 (set! debug? #t)
                 (execute-callback)
                 (set! debug? #f)]
                [else
                 (already-debugging tab)])))
          
          (define/override (execute-callback)
            (let ([tab (get-current-tab)])
              (cond
                [(eq? tab (send tab get-master))
                 (send (get-current-tab) prepare-execution debug?)
                 (super execute-callback)]
                [else
                 (already-debugging tab)])))
          
          (define/private (already-debugging tab)
            (message-box
             "Debugger"
             (format "This file is involved in a debugging session.  To run/debug this file, finish the session for ~a and close or re-run it."
                     (send (send (send tab get-master) get-defs) get-filename/untitled-name))
             this '(ok)))
          
          (define expr-positions empty)
          (define expr-lengths empty)
          
          (define/public (register-vars frame)
            (send variables-text begin-edit-sequence)
            (send variables-text lock #f)
            (send variables-text delete 0 (send variables-text last-position))
            (for-each
             (lambda (name/value)
               (let ([name (format "~a" (syntax-e (first name/value)))]
                     [value (format " => ~s\n" (second name/value))])
                 (send variables-text insert name)
                 (send variables-text change-style bold-sd
                       (- (send variables-text last-position) (string-length name))
                       (send variables-text last-position))
                 (send variables-text insert value)
                 (send variables-text change-style normal-sd
                       (- (send variables-text last-position) (string-length value))
                       (send variables-text last-position))))
             (third (expose-mark frame)))
            (send variables-text lock #t)
            (send variables-text end-edit-sequence))
          
          (define/public (register-stack-frames frames already-stopped?)
            (let* ([trimmed-exprs
                    (map (lambda (frame)
                           (let ([expr (mark-source frame)])
                             (cond
                               ; should succeed unless the user closes a slave tab during debugging
                               [(and expr (filename->defs (syntax-source expr)))
                                => (lambda (defs)
                                     (trim-expr-str
                                      (if (syntax-position expr)
                                          (send defs get-text
                                                (sub1 (syntax-position expr))
                                                (+ -1 (syntax-position expr) (syntax-span expr)))
                                          "??")
                                      15))]
                               ["??"])))
                         frames)]
                   [trimmed-lengths (map add1 (map string-length trimmed-exprs))]
                   [positions (foldl + 0 trimmed-lengths)])
              (send stack-frames begin-edit-sequence)
              (send stack-frames lock #f)
              (unless already-stopped?
                (send stack-frames delete 0 (send stack-frames last-position))
                (for-each (lambda (trimmed-expr)
                            (send stack-frames insert (format "~a\n" trimmed-expr)))
                          trimmed-exprs))
              (send stack-frames change-style normal-sd 0 (send stack-frames last-position))
              (send stack-frames change-style bold-sd
                    (send stack-frames paragraph-start-position (send (get-current-tab) get-frame-num))
                    (send stack-frames paragraph-end-position (send (get-current-tab) get-frame-num)))
              (send stack-frames lock #t)
              (send stack-frames end-edit-sequence)))
          
          (define/public (clear-stack-frames/vars)
            (send stack-frames begin-edit-sequence)
            (send stack-frames lock #f)
            (send stack-frames delete 0 (send stack-frames last-position))
            (send stack-frames lock #t)
            (send stack-frames end-edit-sequence)
            (send variables-text begin-edit-sequence)
            (send variables-text lock #f)
            (send variables-text delete 0 (send variables-text last-position))
            (send variables-text lock #t)
            (send variables-text end-edit-sequence))
          
          (define debug-grandparent-panel 'uninitialized-debug-grandparent-panel)
          (define debug-parent-panel 'uninitialized-debug-parent-panel)
          (define debug-panel 'uninitialized-debug-panel)
          (define stack-view-panel 'uninitialized-stack-view-panel)
          (define stack-frames 'uninitialized-stack-frames)
          (define variables-text 'uninitialized-variables-text)
          (define highlight-color (make-object color% 207 255 207))
          (define bold-sd (make-object style-delta% 'change-weight 'bold))
          (define normal-sd (make-object style-delta% 'change-weight 'normal))
          (define mouse-over-frame #f)
          (define/override (get-definitions/interactions-panel-parent)
            (set! debug-grandparent-panel
                  (make-object horizontal-panel%
                    (super get-definitions/interactions-panel-parent)))
            (set! stack-view-panel
                  (new panel:vertical-dragable%
                       [parent debug-grandparent-panel]
                       [min-width 160]
                       [stretchable-width #f]))
            (set! stack-frames
                  (new (class text%
                         (super-new)
                         (inherit find-line line-start-position line-end-position
                                  change-style begin-edit-sequence end-edit-sequence
                                  lock last-position line-paragraph find-position
                                  dc-location-to-editor-location)
                         (define highlight-defs #f)
                         (define highlight-start #f)
                         (define highlight-end #f)
                         (define mouse-over-frame #f)
                         (define/override (on-event evt)
                           (let*-values ([(x y) (dc-location-to-editor-location
                                                 (send evt get-x) (send evt get-y))]
                                         [(line) (find-line y)]
                                         [(pos) (find-position x y)]
                                         [(paragraph) (line-paragraph line)]
                                         [(frames) (send (get-current-tab) get-stack-frames)]
                                         [(frame) (and frames
                                                       (> (length frames) paragraph)
                                                       (list-ref frames paragraph))]
                                         [(expr) (and frame (mark-source frame))])
                             (case (send evt get-event-type)
                               [(enter motion)
                                (when (and mouse-over-frame (not (= paragraph mouse-over-frame)))
                                  ;; motion to different frame: unhighlight old
                                  (send highlight-defs unhighlight-range
                                        highlight-start highlight-end highlight-color)
                                  (set! mouse-over-frame #f))
                                (when (and expr (not (eq? mouse-over-frame paragraph)))
                                  ;; motion to frame: highlight new
                                  (cond
                                    [(filename->defs (syntax-source expr))
                                     => (lambda (defs)
                                          (set! mouse-over-frame paragraph)
                                          (set! highlight-defs defs)
                                          (set! highlight-start (sub1 (syntax-position expr)))
                                          (set! highlight-end (+ -1 (syntax-position expr)
                                                                 (syntax-span expr)))
                                          (send defs highlight-range
                                                highlight-start highlight-end highlight-color)
                                          (cond
                                            [(send defs get-filename)
                                             => (lambda (fn) (handler:edit-file fn))])
                                          (send defs scroll-to-position (syntax-position expr)))]))]
                               [(leave)
                                (when mouse-over-frame
                                  ;; motion to different frame: unhighlight old
                                  (send highlight-defs unhighlight-range
                                        highlight-start highlight-end highlight-color)
                                  (set! mouse-over-frame #f))
                                (cond
                                  [(send (get-current-tab) get-frame-num)
                                   => (lambda (num) (send (get-current-tab) move-to-frame num))])]
                               [(left-down)
                                (when (and paragraph expr)
                                  (send (get-current-tab) move-to-frame paragraph))]
                               [else (void)]))))))
            (set! variables-text (new text% [auto-wrap #t]))
            (let ([stack-frames-panel (make-object vertical-panel% stack-view-panel)])
              (new message% [parent stack-frames-panel] [label "Stack"])
              (new editor-canvas% [parent stack-frames-panel] [editor stack-frames] [style '(no-hscroll)]))
            (let ([variables-panel (make-object vertical-panel% stack-view-panel)])
              (new message% [parent variables-panel] [label "Variables"])
              (new editor-canvas% [parent variables-panel] [editor variables-text] [style '(no-hscroll)]))
            ;; parent of panel with debug buttons
            (set! debug-parent-panel
                  (make-object vertical-panel% debug-grandparent-panel))
            ;; horizontal panel with debug buttons; not vertically stretchable
            (set! debug-panel (instantiate horizontal-panel% ()
                                (parent debug-parent-panel)
                                (stretchable-height #f)
                                (alignment '(center center))
                                (style '(border))))
            ;; hide the debug panel and stack view initially
            (send debug-parent-panel change-children (lambda (l) null))
            (send debug-grandparent-panel change-children (lambda (l) (remq stack-view-panel l)))
            (make-object vertical-panel% debug-parent-panel))
          
          (define/public (hide-debug)
            (when (member debug-panel (send debug-parent-panel get-children))
              (send debug-grandparent-panel change-children
                    (lambda (l) (remq stack-view-panel l)))
              (send debug-parent-panel change-children
                    (lambda (l) (remq debug-panel l)))))
          
          (define/public (show-debug)
            (unless (member debug-panel (send debug-parent-panel get-children))
              (send debug-grandparent-panel change-children
                    (lambda (l) (append l (list stack-view-panel))))
              (send debug-parent-panel change-children
                    (lambda (l) (cons debug-panel l)))))
          
          (super-new)
          
          (define status-message
            (instantiate message% ()
              [label " "]
              [parent debug-panel]
              [stretchable-width #t]))
          
          (define debug-button
            (new switchable-button%
                 (label (string-constant debug-tool-button-name))
                 (bitmap debug-bitmap)
                 (parent (new vertical-pane%
			      [parent (get-button-panel)]
			      [alignment '(center center)]))
                 (callback (λ (button) (debug-callback)))))
          (inherit register-toolbar-button)
          (register-toolbar-button debug-button)

          (define/augment (enable-evaluation)
            (send debug-button enable #t)
            (inner (void) enable-evaluation))

          (define/augment (disable-evaluation)
            (send debug-button enable #f)
            (inner (void) disable-evaluation))

          (define pause-button
            (instantiate button% ()
              [label (make-pause-label this)]
              [parent debug-panel]
              [callback (lambda (button evt)
                          (cond [(send (get-current-tab) get-stack-frames) (bell)]
                                [else (send (get-current-tab) suspend-on-break? #t)
                                      (send (get-current-tab) break-callback)
                                      (send (get-current-tab) reset-offer-kill)]))]
              [enabled #t]))
          
          (define resume-button
            (instantiate button% ()
              [label (make-resume-label this)]
              [parent debug-panel]
              [callback (lambda (button evt)
                          (if (send (get-current-tab) get-stack-frames)
                              (send (get-current-tab) resume)
                              (bell)))]
              [enabled #f]))
          
          (define step-button
            (instantiate button% ()
              [label (make-step-label this)]
              [parent debug-panel]
              [callback (lambda (btn evt)
                          (cond [(send (get-current-tab) get-stack-frames)
                                 (send (get-current-tab) set-single-step?! #t)
                                 (send (get-current-tab) resume)]
                                [else (bell)]))]
              [enabled #f]))
          
          (define (make-big-step-callback out?)
            (lambda (btn evt)
              ; go through stack frames until it's possible to set a breakpoint at the end
              (let* ([frames (list-tail (send (get-current-tab) get-stack-frames)
                                        (send (get-current-tab) get-frame-num))]
                     [frames (case (send (get-current-tab) get-break-status)
                               [(entry-break) (if out? (rest frames) frames)]
                               [else (if out? (rest frames) empty)])]
                     [frame (ormap (lambda (f depth)
                                     (let/ec k
                                       (let* ([stx (mark-source f)]
                                              [src (syntax-source stx)]
                                              [lpos (or (syntax-position stx) (k #f))]
                                              [pos (+ lpos (syntax-span stx) -1)]
                                              [defs (filename->defs src)]
                                              [tab (if defs (send defs get-tab) (k #f))]
                                              [bps (send tab get-breakpoints)]
                                              [cur-stat (hash-table-get bps pos 'invalid)])
                                         (case cur-stat
                                           [(invalid) #f]
                                           [else
                                            (hash-table-put!
                                             bps pos
                                             (lambda ()
                                               (and (< (length (continuation-mark-set->list
                                                                (current-continuation-marks) debug-key)) depth)
                                                    (begin
                                                      (hash-table-put! bps pos cur-stat)
                                                      #t))))
                                            f]))))
                                   frames
                                   (let ([len (length frames)])
                                     (build-list len (lambda (i) (- len i)))))])
                (cond [frames (send (get-current-tab) set-single-step?! (not frame))
                              (send (get-current-tab) resume)]
                      [else (bell)]))))
          
          (define step-over-button
            (new button%
                 [label (make-over-label this)]
                 [parent debug-panel]
                 [callback (make-big-step-callback #f)]
                 [enabled #f]))
          
          (define step-out-button
            (new button%
                 [label (make-out-label this)]
                 [parent debug-panel]
                 [callback (make-big-step-callback #t)]
                 [enabled #f]))
          
          (define/public (get-debug-button) debug-button)
          (define/public (get-pause-button) pause-button)
          (define/public (get-resume-button) resume-button)
          (define/public (get-step-button) step-button)
          (define/public (get-step-over-button) step-over-button)
          (define/public (get-step-out-button) step-out-button)
          (define/public (get-status-message) status-message)
          
          (define mouse-over-message
            (instantiate message% ()
              [label " "] [parent debug-panel] [stretchable-width #t]))
          
          (define/augment (on-tab-change old new)
            (check-current-language-for-debugger)
            (if (send new debug?)
                (let ([status (send new get-break-status)])
                  (if status
                      (send new suspend-gui (send new get-stack-frames) status #f #t)
                      (send new resume-gui))
                  (show-debug))
                (hide-debug))
            (inner (void) on-tab-change old new))
          
          (define/public (check-current-language-for-debugger)
            (let* ([settings (send (get-definitions-text) get-next-settings)]
                   [lang (drscheme:language-configuration:language-settings-language settings)]
                   [visible? (and (send lang capability-value 'gui-debugger:debug-button)
                                  (not (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 (_)
                  (cons (send debug-button get-parent)
                        (remq (send debug-button get-parent) _))))
          
          ; hide debug button if it's not supported for the initial language:
          (check-current-language-for-debugger)))
      (drscheme:language:register-capability 'gui-debugger:debug-button (flat-contract boolean?) #t)
      (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin)
      (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin)
      (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin)
      (drscheme:get/extend:extend-tab debug-tab-mixin))))
