896 lines
44 KiB
Scheme
896 lines
44 KiB
Scheme
(module debug-tool mzscheme
|
|
(require (lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "string.ss")
|
|
;(lib "math.ss")
|
|
(lib "class.ss")
|
|
(lib "unit.ss")
|
|
(lib "contract.ss")
|
|
(lib "mred.ss" "mred")
|
|
(prefix drscheme:arrow: (lib "arrow.ss" "drscheme"))
|
|
(lib "tool.ss" "drscheme")
|
|
"marks.ss"
|
|
(lib "boundmap.ss" "syntax")
|
|
(lib "bitmap-label.ss" "mrlib")
|
|
"annotator.ss"
|
|
"load-sandbox.ss"
|
|
;(lib "framework.ss" "framework")
|
|
(lib "string-constant.ss" "string-constants")
|
|
)
|
|
|
|
(provide tool@)
|
|
|
|
(define (robust-syntax-source stx)
|
|
(and (syntax? stx) (syntax-source stx)))
|
|
|
|
; QUESTIONS/IDEAS
|
|
; what is the right way to deal with macros?
|
|
; how can the three tool classes communicate with each other safely
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
(define phase1 void)
|
|
(define phase2 void)
|
|
|
|
(define (extract-language-level settings)
|
|
(let* ([language (drscheme:language-configuration:language-settings-language settings)])
|
|
(car (last-pair (send language get-language-position)))))
|
|
|
|
(define (debugger-does-not-work-for? lang)
|
|
(member lang (list (string-constant beginning-student)
|
|
(string-constant beginning-student/abbrev)
|
|
(string-constant intermediate-student)
|
|
(string-constant intermediate-student/lambda)
|
|
(string-constant advanced-student))))
|
|
|
|
(define (robust-vector-ref vec idx)
|
|
(if (< idx (vector-length vec))
|
|
(vector-ref vec idx)
|
|
#f))
|
|
|
|
(define (break-at bp p)
|
|
(hash-table-get bp p #f))
|
|
|
|
(define (truncate str n)
|
|
(if (< (string-length str) n)
|
|
str
|
|
(if (>= n 3)
|
|
(string-append
|
|
(substring str 0 (- n 3))
|
|
"...")
|
|
(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 (trim-expr-str str)
|
|
(cond
|
|
[(index-of #\newline str) => (lambda (i)
|
|
(string-append
|
|
(substring str 0 i)
|
|
(if (char=? (string-ref str 0) #\()
|
|
" ...)"
|
|
" ...")))]
|
|
[str]))
|
|
|
|
(define (average . values)
|
|
(/ (apply + values) (length values)))
|
|
|
|
(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-tab)
|
|
|
|
(define mouse-over-pos #f)
|
|
(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))
|
|
(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 "pink"
|
|
'solid))
|
|
(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))
|
|
(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))
|
|
(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))
|
|
(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)
|
|
(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-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))
|
|
|
|
(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)])))))
|
|
|
|
(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))
|
|
|
|
(define/override (on-event event)
|
|
(if (send (get-tab) debug?)
|
|
(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)]
|
|
#;
|
|
[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
|
|
frames pos-vec id)])
|
|
(send (get-tab)
|
|
set-mouse-over-msg
|
|
; consider rewriting so we can look up top-level vars even
|
|
; when not suspended
|
|
(cond
|
|
[(and id frames
|
|
(let/ec k
|
|
(let* ([id-sym (syntax-e id)]
|
|
[binding (lookup-first-binding
|
|
(lambda (id2) (module-identifier=? id id2))
|
|
frames (lambda ()
|
|
;(printf "failed to find var ~a on stack~n" id)
|
|
(k (clean-status
|
|
(format "~a = ~a" id-sym
|
|
(render
|
|
((send (get-tab) lookup-top-level-var
|
|
id
|
|
(lambda () (k #f))))))))))]
|
|
[val (mark-binding-value
|
|
binding)])
|
|
(clean-status (format "~a = ~a" id-sym (render val))))))]
|
|
[""]))))))
|
|
(super on-event event)]
|
|
[(send event button-down? 'right)
|
|
(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))])
|
|
(case break-status
|
|
[(#t #f)
|
|
(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 "~a" (cons 'values
|
|
(map (lambda (v) (render v)) (rest stat)))))
|
|
"")])
|
|
(when (cons? stat)
|
|
#;(send (make-object menu-item%
|
|
(clean-status (format "expr -> ~a" rendered-value))
|
|
menu
|
|
void) enable #f)
|
|
(make-object menu-item%
|
|
"Print return value to console"
|
|
menu
|
|
(lambda _ (send (get-tab) print-to-console (format "return val = ~a"
|
|
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? k]) ; LATER: message box
|
|
(eval-string tmp)))
|
|
list))))))))))
|
|
(make-object menu-item%
|
|
"Continue to this point"
|
|
menu
|
|
(lambda (item evt)
|
|
(hash-table-put!
|
|
breakpoints pos
|
|
(lambda () (hash-table-put! breakpoints pos #f) #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))))))]
|
|
[(invalid)
|
|
(let* ([frames (send (get-tab) get-stack-frames)]
|
|
[pos-vec (send (get-tab) get-pos-vec)]
|
|
[id (robust-vector-ref pos-vec pos)]
|
|
#;
|
|
[_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n"
|
|
frames pos-vec id)])
|
|
(unless (and
|
|
id frames
|
|
(let/ec k
|
|
(let* ([id-sym (syntax-e id)]
|
|
[binding (lookup-first-binding
|
|
(lambda (id2) (module-identifier=? id id2))
|
|
frames (lambda () (k #f)))]
|
|
[val (mark-binding-value
|
|
binding)]
|
|
[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 = ~a" 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
|
|
(mark-binding-set! binding (eval-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)))
|
|
(super on-event event)))]))
|
|
(super on-event event)))]
|
|
[else (super on-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))
|
|
(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)])
|
|
;(drscheme:arrow:draw-arrow dc xl yl xr yr dx dy)
|
|
(send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
|
|
#;
|
|
(send dc draw-polygon stop-sign
|
|
(+ xl dx)
|
|
(+ yl dy 2))
|
|
(send dc set-pen op)
|
|
(send dc set-brush ob)))))))
|
|
(let ([pos (send (get-tab) get-pc)])
|
|
(when pos
|
|
(let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
|
|
[(ym) (average yl yr)])
|
|
(let ([op (send dc get-pen)]
|
|
[ob (send dc get-brush)])
|
|
(case (send (get-tab) get-break-status)
|
|
[(error) (send dc set-pen pc-err-pen)
|
|
(send dc set-brush pc-err-brush)]
|
|
[(break) (send dc set-pen pc-brk-pen)
|
|
(send dc set-brush pc-brk-brush)]
|
|
[else (send dc set-pen pc-pen)
|
|
(send dc set-brush pc-brush)]))
|
|
(drscheme:arrow:draw-arrow dc xl ym xr ym dx dy))
|
|
#;
|
|
(let loop ([end-pos pos]
|
|
[marks (send (get-tab) get-stack-frames)])
|
|
(when (cons? marks)
|
|
(let*-values ([(start-pos) (syntax-position (mark-source (first marks)))]
|
|
[(xl0 yl0 xr0 yr0) (find-char-box this (sub1 start-pos) start-pos)]
|
|
[(xm0) (average xl0 xr0)]
|
|
[(ym0) (average yl0 yr0)]
|
|
[(xl yl xr yr) (find-char-box this (sub1 end-pos) end-pos)]
|
|
[(xm) (average xl xr)]
|
|
[(ym) (average yl yr)])
|
|
(let ([op (send dc get-pen)]
|
|
[ob (send dc get-brush)])
|
|
(case (send (get-tab) get-break-status)
|
|
[(error) (send dc set-pen pc-err-pen)
|
|
(send dc set-brush pc-err-brush)]
|
|
[(break) (send dc set-pen pc-brk-pen)
|
|
(send dc set-brush pc-brk-brush)]
|
|
[else (send dc set-pen pc-pen)
|
|
(send dc set-brush pc-brush)]))
|
|
(drscheme:arrow:draw-arrow dc xm0 ym0 xr ym dx dy)
|
|
(loop start-pos (rest marks)))))))))
|
|
|
|
(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
|
|
display-results
|
|
#;get-tab)
|
|
|
|
(super-instantiate ())
|
|
|
|
(define tab #f)
|
|
(define/private (get-tab) tab)
|
|
(define/public (set-tab t) (set! tab t))
|
|
|
|
;; 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 loop ([exp (if (syntax? orig-exp)
|
|
orig-exp
|
|
(namespace-syntax-introduce
|
|
(datum->syntax-object #f orig-exp)))])
|
|
(let ([top-e (expand-syntax-to-top-form exp)])
|
|
(parameterize ([current-eval oe])
|
|
(eval/annotations
|
|
top-e
|
|
(lambda (fn m) #f) ; TODO: multiple file support
|
|
(lambda (stx)
|
|
(let*-values ([(breakpoints) (send (get-tab) get-breakpoints)]
|
|
[(pos-vec) (send (get-tab) get-pos-vec)]
|
|
[(annotated break-posns)
|
|
(annotate-for-single-stepping
|
|
(expand-syntax top-e)
|
|
break?
|
|
break-before
|
|
break-after
|
|
(lambda (type bound binding)
|
|
;(display-results (list bound))
|
|
(when (eq? (robust-syntax-source bound)
|
|
(robust-syntax-source exp))
|
|
(let loop ([i 0])
|
|
(when (< i (syntax-span bound))
|
|
(vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
|
(loop (add1 i))))))
|
|
(lambda (mod var val)
|
|
(send (get-tab) add-top-level-binding var val)
|
|
#;
|
|
(printf "top-level binding: ~a ~a ~a~n" mod var val))
|
|
(send (get-tab) get-defs))])
|
|
(hash-table-for-each
|
|
breakpoints
|
|
(lambda (pos status)
|
|
; possible efficiency problem for large files with many breakpoints
|
|
(when (and (syntax-position top-e)
|
|
(>= pos (syntax-position top-e))
|
|
(< pos (+ (syntax-position top-e) (syntax-span top-e)))
|
|
(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)
|
|
;(display-results (list orig-exp))
|
|
annotated)))))))))
|
|
|
|
(define/override (reset-console)
|
|
(super reset-console)
|
|
(when (and (get-tab) (send (get-tab) debug?))
|
|
(let ([breakpoints (send (get-tab) get-breakpoints)])
|
|
(run-in-evaluation-thread
|
|
(lambda ()
|
|
;(print-struct #t)
|
|
(let ([self (current-thread)]
|
|
[oeh (uncaught-exception-handler)]
|
|
[err-hndlr (error-display-handler)])
|
|
(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)
|
|
(lambda (pos)
|
|
(or (hash-table-get breakpoints -1)
|
|
(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)
|
|
|
|
(define breakpoints (make-hash-table))
|
|
(hash-table-put! breakpoints -1 #f)
|
|
(define suspend-sema (make-semaphore 1))
|
|
(define resume-ch (make-channel))
|
|
(define in-user-ch (make-channel))
|
|
(define want-suspend-on-break? #f)
|
|
(define want-debug? #f)
|
|
(define/public (debug?) want-debug?)
|
|
(define stack-frames #f)
|
|
(define current-language-settings #f)
|
|
(define pos-vec (make-vector 1))
|
|
(define/public suspend-on-break?
|
|
(case-lambda
|
|
[() want-suspend-on-break?]
|
|
[(v) (set! want-suspend-on-break? v)]))
|
|
(define/public (get-stack-frames) stack-frames)
|
|
(define/public (get-pos-vec) pos-vec)
|
|
(define/public (get-breakpoints) breakpoints)
|
|
(define break-status #f)
|
|
(define/public (get-break-status) break-status)
|
|
(define/public (set-break-status stat) (set! break-status stat))
|
|
(define top-level-bindings empty)
|
|
(define/public (add-top-level-binding var val)
|
|
(set! top-level-bindings (cons (cons var val) top-level-bindings)))
|
|
(define/public (lookup-top-level-var var failure-thunk)
|
|
#;
|
|
(printf "looking for ~a in ~a~n" var top-level-bindings)
|
|
(let loop ([bindings top-level-bindings])
|
|
(cond
|
|
[(empty? bindings) (failure-thunk)]
|
|
[(let ([res (or (bound-identifier=? var (caar bindings))
|
|
(free-identifier=? var (caar bindings)))])
|
|
#;
|
|
(printf "~a = ~a -> ~a~n" var (caar bindings) res)
|
|
res) (cdar bindings)]
|
|
[(loop (rest bindings))])))
|
|
(define control-panel #f)
|
|
(define/public (resume)
|
|
(let ([v break-status])
|
|
(resume-gui)
|
|
(channel-put resume-ch (if (pair? v)
|
|
(cdr v)
|
|
#f))))
|
|
(define/public (set-mouse-over-msg msg)
|
|
(send (get-frame) set-mouse-over-msg msg))
|
|
|
|
(define/public (get-pc)
|
|
(if (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? break-status)
|
|
end
|
|
start))
|
|
#f))
|
|
|
|
(define/public (render v)
|
|
;; ==drscheme eventspace thread==
|
|
;; only when a user thread is suspended
|
|
(let ([result-ch (make-channel)])
|
|
(channel-put in-user-ch (lambda ()
|
|
(let ([s (open-output-string)])
|
|
(send (drscheme:language-configuration:language-settings-language
|
|
current-language-settings)
|
|
render-value
|
|
v
|
|
(drscheme:language-configuration:language-settings-settings
|
|
current-language-settings)
|
|
s)
|
|
(channel-put result-ch (get-output-string s)))))
|
|
(channel-get result-ch)))
|
|
|
|
(define/public (print-to-console v)
|
|
;; ==drscheme eventspace thread==
|
|
;; only when a user thread is suspended
|
|
(channel-put in-user-ch (lambda () (fprintf (current-error-port) " ### DEBUGGER: ~a~n" v))))
|
|
|
|
(define/public (suspend-gui frames status)
|
|
(set! want-suspend-on-break? #f)
|
|
(hash-table-put! breakpoints -1 #f)
|
|
(send (send (get-frame) get-pause-button) enable #f)
|
|
(send (send (get-frame) get-step-button) enable #t)
|
|
(send (send (get-frame) get-resume-button) enable #t)
|
|
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
|
|
;;(printf "status = ~a~n" status)
|
|
(set! stack-frames frames)
|
|
(set! break-status status)
|
|
(when (cons? status)
|
|
(let ([expr (mark-source (first frames))])
|
|
(send (send (get-frame) get-status-message) set-label
|
|
(clean-status
|
|
(format "~a ==> ~a"
|
|
(trim-expr-str
|
|
(send (get-defs) get-text
|
|
(sub1 (syntax-position expr))
|
|
(+ -1 (syntax-position expr) (syntax-span expr))))
|
|
(if (= 2 (length status))
|
|
(render (cadr status))
|
|
(cons 'values (map (lambda (v) (render v)) (rest status)))))))))
|
|
(cond [(get-pc) => (lambda (pc) (send (get-defs) scroll-to-position pc))])
|
|
(send (get-defs) invalidate-bitmap-cache))
|
|
|
|
(define/public (resume-gui)
|
|
(set! stack-frames #f)
|
|
(set! break-status #f)
|
|
(send (send (get-frame) get-pause-button) enable #t)
|
|
(send (send (get-frame) get-step-button) enable #f)
|
|
(send (send (get-frame) get-resume-button) enable #f)
|
|
(send (send (get-frame) get-status-message) set-label "")
|
|
(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
|
|
(if (semaphore-try-wait? suspend-sema)
|
|
(begin
|
|
(parameterize ([current-eventspace (send (get-frame) get-eventspace)])
|
|
(queue-callback (lambda () (suspend-gui frames status))))
|
|
(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))))
|
|
(if (pair? status)
|
|
(cdr status)
|
|
#f))))
|
|
|
|
(define/public (prepare-execution debug?)
|
|
(set! want-debug? debug?)
|
|
(if debug?
|
|
(send (get-frame) show-debug)
|
|
(send (get-frame) hide-debug))
|
|
(set! current-language-settings
|
|
(and debug? (send (get-defs) get-next-settings)))
|
|
;(set! breakpoints (make-hash-table))
|
|
(hash-table-put! breakpoints -1 #t)
|
|
(set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f))
|
|
(set! top-level-bindings empty)
|
|
(set! resume-ch (make-channel))
|
|
(set! want-suspend-on-break? #f)
|
|
(set! stack-frames #f)
|
|
(send (get-ints) set-tab this))
|
|
|
|
(define/public (hide-debug)
|
|
(send (get-frame) hide-debug))
|
|
|
|
(define/override (enable-evaluation)
|
|
(send (send (get-frame) get-debug-button) enable #t)
|
|
(super enable-evaluation))
|
|
|
|
(define/override (disable-evaluation)
|
|
(send (send (get-frame) get-debug-button) enable #f)
|
|
(super disable-evaluation))
|
|
|
|
(super-new)))
|
|
|
|
(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/public (set-mouse-over-msg msg)
|
|
(when (not (string=? msg (send mouse-over-message get-label)))
|
|
(send mouse-over-message set-label msg)))
|
|
|
|
(define/override (execute-callback)
|
|
(send (get-current-tab) prepare-execution #f)
|
|
(super execute-callback))
|
|
|
|
(define debug-parent-panel 'uninitialized-debug-parent-panel)
|
|
(define debug-panel 'uninitialized-debug-panel)
|
|
(define/override (get-definitions/interactions-panel-parent)
|
|
(set! debug-parent-panel
|
|
(make-object vertical-panel%
|
|
(super get-definitions/interactions-panel-parent)))
|
|
(set! debug-panel (instantiate horizontal-panel% ()
|
|
(parent debug-parent-panel)
|
|
(stretchable-height #f)
|
|
(alignment '(center center))
|
|
(style '(border))))
|
|
(send debug-parent-panel change-children (lambda (l) null))
|
|
#;
|
|
(instantiate button% ()
|
|
(label "Hide")
|
|
(parent debug-panel)
|
|
(callback (lambda (x y) (hide-debug)))
|
|
(stretchable-height #t))
|
|
(make-object vertical-panel% debug-parent-panel))
|
|
|
|
(define/public (hide-debug)
|
|
(when (member debug-panel (send debug-parent-panel get-children))
|
|
(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-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
|
|
(make-object button%
|
|
((bitmap-label-maker
|
|
(string-constant debug-tool-button-name)
|
|
(build-path (collection-path "mztake" "icons") "icon-small.png")) this)
|
|
(make-object vertical-pane% (get-button-panel))
|
|
(lambda (button evt)
|
|
(send (get-current-tab) prepare-execution #t)
|
|
(super execute-callback))))
|
|
|
|
(define pause-button
|
|
(instantiate button% ()
|
|
[label ((bitmap-label-maker
|
|
"Pause"
|
|
(build-path (collection-path "mztake" "icons") "pause.png")) this)]
|
|
[parent debug-panel]
|
|
[callback (lambda (button evt)
|
|
(if (send (get-current-tab) get-stack-frames)
|
|
(bell)
|
|
(begin
|
|
(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 ((bitmap-label-maker
|
|
"Continue"
|
|
(build-path (collection-path "mztake" "icons") "resume.png")) 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 ((bitmap-label-maker
|
|
"Step"
|
|
(build-path (collection-path "mztake" "icons") "step.png")) this)]
|
|
[parent debug-panel]
|
|
[callback (lambda (btn evt)
|
|
(if (send (get-current-tab) get-stack-frames)
|
|
(begin
|
|
(hash-table-put! (send (get-current-tab) get-breakpoints) -1 #t)
|
|
(send (get-current-tab) resume))
|
|
(bell)))]
|
|
[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-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)
|
|
(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 'mztake:debug-button)
|
|
(not (debugger-does-not-work-for?
|
|
(extract-language-level settings))))])
|
|
(if visible?
|
|
(unless (send debug-button is-shown?)
|
|
(send (send debug-button get-parent) add-child debug-button))
|
|
(when (send debug-button is-shown?)
|
|
(send (send debug-button get-parent) delete-child debug-button)))))
|
|
|
|
(send (get-button-panel) change-children
|
|
(lambda (_)
|
|
(cons (send debug-button get-parent)
|
|
(remq (send debug-button get-parent) _))))
|
|
|
|
; hide debug button if it's not supported for the initial language:
|
|
(check-current-language-for-debugger)))
|
|
(drscheme:language:register-capability 'mztake: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))))
|