suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

use text% objects for stack and variables

Browse Source 
to do: documentation, change style of selected frame

svn: r9507
This commit is contained in:
Greg Cooper 2008-04-28 02:04:44 +00:00
parent 30eb4e6a58
commit 12a1526e1f
1 changed files with 152 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
collects/gui-debugger/debug-tool.ss
View File

@ -85,13 +85,15 @@
;; really-long-identifier => really-lon... ;; really-long-identifier => really-lon...
;; (<form>) => (<form>) ;; (<form>) => (<form>)
;; (<form> <arg1> ... <argn>) => (<form> ...) ;; (<form> <arg1> ... <argn>) => (<form> ...)
(define (trim-expr-str str) (define trim-expr-str
(let ([starts-with-paren (and (> (string-length str) 0))]) (opt-lambda (str [len 10])
(let ([starts-with-paren (and (> (string-length str) 0))]
[len2 (+ len 4)])
(cond (cond
[(and starts-with-paren [(and starts-with-paren
(or (index-of #\space str) (or (index-of #\space str)
(index-of #\newline str) (index-of #\newline str)
(and (> (string-length str) 14) 10))) (and (> (string-length str) len2) len)))
;; non-atomic expr: truncate to (form-name ...) ;; non-atomic expr: truncate to (form-name ...)
=> (lambda (i) => (lambda (i)
(string-append (string-append
@ -99,7 +101,7 @@
(if starts-with-paren (if starts-with-paren
" ...)" " ...)"
" ...")))] " ...")))]
[str]))) [str]))))
(define (average . values) (define (average . values)
(/ (apply + values) (length values))) (/ (apply + values) (length values)))
@ -920,6 +922,7 @@
(send (send (get-frame) get-step-out-button) enable (can-step-out? 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) (send (send (get-frame) get-resume-button) enable #t)
(send (get-frame) register-stack-frames frames) (send (get-frame) register-stack-frames frames)
(send (get-frame) register-vars (list-ref frames (get-frame-num)))
;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames)) ;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames))
;;(printf "status = ~a~n" status) ;;(printf "status = ~a~n" status)
(send status-message set-label (send status-message set-label
@ -940,7 +943,8 @@
"??") "??")
(if (= 2 (length status)) (if (= 2 (length status))
(render (cadr status)) (render (cadr status))
(cons 'values (map (lambda (v) (render v)) (rest status)))))))] (cons 'values (map (lambda (v) (render v))
(rest status)))))))]
[""])) [""]))
"")) ""))
(cond [(get-current-frame-endpoints) (cond [(get-current-frame-endpoints)
@ -1077,100 +1081,158 @@
this this
'(ok)))))) '(ok))))))
(define max-stack-frames 40) (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)
(send variables-text insert
(format "~a => ~a~n" (syntax-e (first name/value)) (second name/value))))
(third (expose-mark frame)))
(send variables-text lock #t)
(send variables-text end-edit-sequence))
(define/public (register-stack-frames frames) (define/public (register-stack-frames frames)
(let loop ([i 0] [frames frames]) (let* ([trimmed-exprs
(when (< i max-stack-frames) (map (lambda (frame)
(send (list-ref stack-frames i) set-expr (let ([expr (mark-source frame)])
(and (cons? frames) (mark-source (first frames)))) (cond
(loop (add1 i) (and (cons? frames) (rest frames)))))) ; 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)
(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 lock #t)
(send stack-frames end-edit-sequence)))
(define/public (clear-stack-frames) (define/public (clear-stack-frames)
(let loop ([i 0]) (send stack-frames begin-edit-sequence)
(when (< i max-stack-frames) (send stack-frames lock #f)
(send (list-ref stack-frames i) set-expr #f) (send stack-frames delete 0 (send stack-frames last-position))
(loop (add1 i))))) (send stack-frames lock #t)
(send stack-frames end-edit-sequence))
(define debug-grandparent-panel 'uninitialized-debug-grandparent-panel) (define debug-grandparent-panel 'uninitialized-debug-grandparent-panel)
(define debug-parent-panel 'uninitialized-debug-parent-panel) (define debug-parent-panel 'uninitialized-debug-parent-panel)
(define debug-panel 'uninitialized-debug-panel) (define debug-panel 'uninitialized-debug-panel)
(define stack-view-panel 'uninitialized-stack-view-panel) (define stack-view-panel 'uninitialized-stack-view-panel)
(define stack-frames 'uninitialized-stack-frames) (define stack-frames 'uninitialized-stack-frames)
(define variables-text 'uninitialized-variables-text)
(define highlight-color (make-object color% 207 255 207)) (define highlight-color (make-object color% 207 255 207))
(define bold-sd (make-object style-delta% 'change-weight 'bold))
(define fixed-width-sd (make-object style-delta% 'change-family 'modern))
(send bold-sd set-weight-on 'bold)
(define mouse-over-frame #f) (define mouse-over-frame #f)
(define refresh-timer (new timer% [notify-callback
(lambda ()
(unless mouse-over-frame
(send (get-current-tab) move-to-frame
(send (get-current-tab) get-frame-num))))]))
(define/override (get-definitions/interactions-panel-parent) (define/override (get-definitions/interactions-panel-parent)
(set! debug-grandparent-panel (set! debug-grandparent-panel
(make-object horizontal-panel% (make-object horizontal-panel%
(super get-definitions/interactions-panel-parent))) (super get-definitions/interactions-panel-parent)))
(set! stack-view-panel (set! stack-view-panel
(new vertical-panel% (new panel:vertical-dragable%
[parent debug-grandparent-panel] [parent debug-grandparent-panel]
[min-width 160]
[stretchable-width #f])) [stretchable-width #f]))
(new message% [parent stack-view-panel] [label "Context"]
[font (make-object font% 18 'default 'normal 'bold #t)])
(set! stack-frames (set! stack-frames
(build-list max-stack-frames (new (class text%
(lambda (i)
(new (class message%
(super-new) (super-new)
(inherit set-label get-label) (inherit find-line line-start-position line-end-position
(define expr #f) change-style begin-edit-sequence end-edit-sequence
(define/public (set-expr expr1) lock last-position)
(set! expr expr1) (define highlight-defs #f)
(set-label (define highlight-start #f)
(cond (define highlight-end #f)
; should succeed unless the user closes a slave tab during debugging (define mouse-over-frame #f)
[(and expr (filename->defs (syntax-source expr))) (define/override (on-event evt)
=> (let* ([line (find-line (send evt get-y))]
(lambda (defs) [frames (send (get-current-tab) get-stack-frames)]
(clean-status [frame (and frames
(if (syntax-position expr) (> (length frames) line)
(send defs get-text (list-ref frames line))]
(sub1 (syntax-position expr)) [expr (and frame (mark-source frame))])
(+ -1 (syntax-position expr) (syntax-span expr)))
"??")))]
[""])))
(define/override (on-subwindow-event msg evt)
(case (send evt get-event-type) (case (send evt get-event-type)
[(enter) (cond [(enter motion)
[(and expr (filename->defs (syntax-source expr))) (when (and mouse-over-frame (not (= line 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)
(set! highlight-defs #f)
(set! highlight-start #f)
(set! highlight-end #f))
(when (and expr (not (eq? mouse-over-frame line)))
;; motion to frame: highlight new
(cond
[(filename->defs (syntax-source expr))
=> (lambda (defs) => (lambda (defs)
(set! mouse-over-frame line)
(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 (send defs highlight-range
(sub1 (syntax-position expr)) highlight-start highlight-end highlight-color)
(+ -1 (syntax-position expr)
(syntax-span expr))
highlight-color)
(cond (cond
[(send defs get-filename) [(send defs get-filename)
=> =>
(lambda (fn) (lambda (fn)
(handler:edit-file fn))]) (handler:edit-file fn))])
(send defs scroll-to-position (send defs scroll-to-position
(syntax-position expr)))]) (syntax-position expr)))]))]
(when expr [(leave)
(set! mouse-over-frame i))] (when mouse-over-frame
[(leave) (cond ;; motion to different frame: unhighlight old
[(and expr (filename->defs (syntax-source expr))) (send highlight-defs unhighlight-range
=> (lambda (defs) highlight-start highlight-end highlight-color)
(send defs unhighlight-range
(sub1 (syntax-position expr))
(+ -1 (syntax-position expr)
(syntax-span expr))
highlight-color))])
(set! mouse-over-frame #f) (set! mouse-over-frame #f)
(when expr (set! highlight-defs #f)
(send refresh-timer start 250 #t))] (set! highlight-start #f)
[(left-down) (when expr (set! highlight-end #f))
(send (get-current-tab) move-to-frame i))]))) (cond
[parent stack-view-panel] [(send (get-current-tab) get-frame-num)
[stretchable-width #f] => (lambda (num)
[label (make-string 30 #\ )])))) (send (get-current-tab) move-to-frame num))])]
[(left-down)
(when (and line expr)
(begin-edit-sequence)
(lock #f)
(change-style fixed-width-sd 0 (last-position)
;(line-start-position line)
#;(line-end-position line))
(lock #t)
(end-edit-sequence)
(send (get-current-tab) move-to-frame line))]
[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 ;; parent of panel with debug buttons
(set! debug-parent-panel (set! debug-parent-panel
(make-object vertical-panel% debug-grandparent-panel)) (make-object vertical-panel% debug-grandparent-panel))
@ -1281,7 +1343,8 @@
(hash-table-put! (hash-table-put!
bps pos bps pos
(lambda () (lambda ()
(and (< (length (continuation-mark-set->list (current-continuation-marks) debug-key)) depth) (and (< (length (continuation-mark-set->list
(current-continuation-marks) debug-key)) depth)
(begin (begin
(hash-table-put! bps pos cur-stat) (hash-table-put! bps pos cur-stat)
#t)))) #t))))