230 lines
9.5 KiB
Racket
230 lines
9.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract
|
|
racket/unit
|
|
racket/class
|
|
racket/path
|
|
racket/port
|
|
racket/list
|
|
racket/gui/base
|
|
string-constants
|
|
framework
|
|
(prefix-in tr: trace/stacktrace)
|
|
"drsig.rkt")
|
|
|
|
(provide tracing@)
|
|
|
|
(define-unit tracing@
|
|
(import [prefix drracket:frame: drracket:frame^]
|
|
[prefix drracket:rep: drracket:rep^]
|
|
[prefix drracket:init: drracket:init^]
|
|
[prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export drracket:tracing^)
|
|
|
|
(define-local-member-name
|
|
get-tracing-text
|
|
show-tracing
|
|
tracing:add-line
|
|
tracing:rest)
|
|
(define tab-tracing<%>
|
|
(interface ()
|
|
get-tracing-text
|
|
get-any-results?
|
|
tracing:add-line
|
|
tracing:reset))
|
|
|
|
(define ellipses-cutoff 200)
|
|
(define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
|
|
|
|
(define (print-call-trace inferred-name original? src args improper? depth)
|
|
(when inferred-name
|
|
(let ([name (cond
|
|
[(identifier? inferred-name) (syntax-e inferred-name)]
|
|
[else (object-name inferred-name)])]
|
|
[rep (drracket:rep:current-rep)])
|
|
(when (and name rep)
|
|
(let ([canvas (send rep get-canvas)])
|
|
(when canvas
|
|
(let* ([frame (send canvas get-top-level-window)]
|
|
[tab (send frame get-current-tab)])
|
|
(when (is-a? tab tab-tracing<%>)
|
|
(let ([sp (open-output-string)])
|
|
(let loop ([i depth])
|
|
(unless (zero? i)
|
|
(display " " sp)
|
|
(loop (- i 1))))
|
|
(fprintf sp "(")
|
|
(fprintf sp "~a" name)
|
|
(let loop ([args args])
|
|
(cond
|
|
[(null? args) (void)]
|
|
[(and (null? (cdr args)) improper?)
|
|
(fprintf sp " . ")
|
|
(fprintf sp "~v" (car args))]
|
|
[else
|
|
(let ([arg (car args)])
|
|
(fprintf sp " ")
|
|
(fprintf sp "~v" arg))
|
|
(loop (cdr args))]))
|
|
(fprintf sp ")")
|
|
(let ([sema (make-semaphore)])
|
|
;; Disable breaks, so an exn handler can't
|
|
;; grab the DrRacket eventspacae:
|
|
(parameterize-break #f
|
|
;; Queue callback to write trace line ---
|
|
;; low priority, so that infinite loops don't stop the user
|
|
;; from clicking "Break"
|
|
(parameterize ([current-eventspace drracket:init:system-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(send tab tracing:add-line (get-output-string sp))
|
|
(semaphore-post sema))
|
|
#f)))
|
|
;; Wait for the line to get written, so that the
|
|
;; trace output doesn't get too far behind (which
|
|
;; matters, again, for infinite loops)
|
|
(semaphore-wait sema)))))))))))
|
|
|
|
(define-values/invoke-unit tr:stacktrace@
|
|
(import tr:stacktrace-imports^) (export tr:stacktrace^))
|
|
|
|
(define tab-mixin
|
|
(mixin (drracket:unit:tab<%> drracket:rep:context<%>) (tab-tracing<%>)
|
|
(inherit get-frame)
|
|
|
|
(define tracing-visible? #f)
|
|
(define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
|
|
(define/public (get-tracing-visible?) tracing-visible?)
|
|
|
|
(define/augment (clear-annotations)
|
|
(tracing:reset)
|
|
(inner (void) clear-annotations))
|
|
|
|
(define any-results? #f)
|
|
(define/public (get-any-results?) any-results?)
|
|
(define ever-been-reset? #f)
|
|
(define/public (tracing:reset)
|
|
(when (or any-results?
|
|
(not ever-been-reset?))
|
|
(set! any-results? #f)
|
|
(set! ever-been-reset? #t)
|
|
(send show-tracing-text lock #f)
|
|
(send show-tracing-text erase)
|
|
(send show-tracing-text auto-wrap #t)
|
|
(send show-tracing-text insert (string-constant tracing-tracing-nothing-to-show))
|
|
(send show-tracing-text lock #t)))
|
|
|
|
(define show-tracing-text (new text:hide-caret/selection%))
|
|
(define/public (get-tracing-text) show-tracing-text)
|
|
(send show-tracing-text lock #t)
|
|
|
|
(define/public (tracing:add-line s)
|
|
(let ([old-any? any-results?])
|
|
(set! any-results? #t)
|
|
(unless old-any?
|
|
(send (get-frame) show-tracing))
|
|
(send show-tracing-text begin-edit-sequence)
|
|
(send show-tracing-text lock #f)
|
|
(unless old-any?
|
|
(send show-tracing-text erase)
|
|
(send show-tracing-text auto-wrap #f))
|
|
(let ([insert
|
|
(lambda (s)
|
|
(send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
|
|
(cond
|
|
[(<= (string-length s) ellipses-cutoff)
|
|
(insert s)
|
|
(insert "\n")]
|
|
[else
|
|
(insert (substring s 0 ellipses-cutoff))
|
|
(insert " ")
|
|
(let ([ell-start (send show-tracing-text last-position)])
|
|
(insert "...")
|
|
(let ([ell-end (send show-tracing-text last-position)])
|
|
(let ([para (send show-tracing-text last-paragraph)])
|
|
(insert "\n")
|
|
(send show-tracing-text change-style clickback-delta ell-start ell-end)
|
|
(send show-tracing-text set-clickback ell-start ell-end
|
|
(lambda (t x y)
|
|
(send show-tracing-text begin-edit-sequence)
|
|
(send show-tracing-text lock #f)
|
|
(let ([line-start (send show-tracing-text paragraph-start-position para)]
|
|
[line-end (send show-tracing-text paragraph-end-position para)])
|
|
(send show-tracing-text delete line-start line-end #f)
|
|
(send show-tracing-text insert s line-start 'same #f))
|
|
(send show-tracing-text lock #t)
|
|
(send show-tracing-text end-edit-sequence))))))]))
|
|
(send show-tracing-text lock #t)
|
|
(send show-tracing-text end-edit-sequence)))
|
|
|
|
(super-new)))
|
|
|
|
(define clickback-delta (make-object style-delta%))
|
|
(send clickback-delta set-delta-foreground "BLUE")
|
|
(send clickback-delta set-delta 'change-underline #t)
|
|
|
|
(define frame-mixin
|
|
(mixin (drracket:frame:<%> drracket:unit:frame<%>) ()
|
|
(inherit get-current-tab set-show-menu-sort-key)
|
|
(define show-tracing-menu-item #f)
|
|
(define tracing-visible? #f)
|
|
|
|
(define/augment (on-tab-change old new)
|
|
(inner (void) on-tab-change old new)
|
|
(send show-tracing-canvas set-editor (send new get-tracing-text))
|
|
(cond
|
|
[(eq? tracing-visible? (send new get-tracing-visible?))
|
|
(void)]
|
|
[(send new get-tracing-visible?)
|
|
(show-tracing)]
|
|
[else
|
|
(hide-tracing)]))
|
|
|
|
(define/override (add-show-menu-items show-menu)
|
|
(super add-show-menu-items show-menu)
|
|
(set! show-tracing-menu-item
|
|
(new menu-item%
|
|
(parent show-menu)
|
|
(label (string-constant tracing-show-tracing-window))
|
|
(callback (lambda (x y) (toggle-tracing)))))
|
|
(set-show-menu-sort-key show-tracing-menu-item 206))
|
|
|
|
(define/public (show-tracing)
|
|
(set! tracing-visible? #t)
|
|
(send show-tracing-menu-item set-label (string-constant tracing-hide-tracing-window))
|
|
(send dragable-parent begin-container-sequence)
|
|
(send dragable-parent change-children
|
|
(lambda (l)
|
|
(let ([without (remq show-tracing-canvas l)])
|
|
(append without (list show-tracing-canvas)))))
|
|
(send dragable-parent set-percentages '(3/4 1/4))
|
|
(send dragable-parent end-container-sequence))
|
|
|
|
(define/private (hide-tracing)
|
|
(set! tracing-visible? #f)
|
|
(send show-tracing-menu-item set-label (string-constant tracing-show-tracing-window))
|
|
(send dragable-parent change-children
|
|
(lambda (l)
|
|
(remq show-tracing-canvas l))))
|
|
|
|
(define/private (toggle-tracing)
|
|
(if tracing-visible?
|
|
(hide-tracing)
|
|
(show-tracing)))
|
|
|
|
(define dragable-parent #f)
|
|
(define show-tracing-parent-panel #f)
|
|
(define show-tracing-canvas #f)
|
|
|
|
(define/override (make-root-area-container cls parent)
|
|
(set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
|
|
(let ([root (make-object cls dragable-parent)])
|
|
(set! show-tracing-canvas (new editor-canvas%
|
|
(parent dragable-parent)
|
|
(editor (send (get-current-tab) get-tracing-text))))
|
|
(send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
|
|
root))
|
|
|
|
(super-new))))
|