84 lines
2.3 KiB
Racket
84 lines
2.3 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/gui/base
|
|
drscheme/tool
|
|
racket/unit)
|
|
|
|
(provide tool@)
|
|
|
|
;; CONSTANTS
|
|
|
|
(define BACKTRACE-NO-MESSAGE "No message.")
|
|
(define LINK-MODULE-SPEC 'rackunit/private/gui/drracket-link)
|
|
|
|
;; ----
|
|
|
|
;; close/eventspace : (a* -> b) -> (a* -> b)
|
|
;; Returns a procedure that executes the procedure in the
|
|
;; eventspace current when close/eventspace was executed.
|
|
;; Effectively, "close" the procedure in the current eventspace.
|
|
(define (close-eventspace f)
|
|
(let ([es (current-eventspace)])
|
|
(lambda args
|
|
(parameterize [(current-eventspace es)]
|
|
(apply f args)))))
|
|
|
|
(define (close-eventspace/async f)
|
|
(let ([es (current-eventspace)])
|
|
(lambda args
|
|
(parameterize ((current-eventspace es))
|
|
(queue-callback (lambda () (apply f args)))))))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
;; show-backtrace : exn -> void
|
|
(define show-backtrace
|
|
(close-eventspace/async
|
|
(lambda (msg bt)
|
|
(drscheme:debug:show-backtrace-window
|
|
(or msg BACKTRACE-NO-MESSAGE)
|
|
bt))))
|
|
|
|
(define (list->srcloc x)
|
|
(make-srcloc (list-ref x 0)
|
|
(list-ref x 1)
|
|
(list-ref x 2)
|
|
(list-ref x 3)
|
|
(list-ref x 4)))
|
|
|
|
(define (get-errortrace-backtrace exn)
|
|
exn)
|
|
|
|
;; show-source : value number number -> void
|
|
(define show-source
|
|
(close-eventspace/async
|
|
(lambda (src pos span)
|
|
(drscheme:debug:open-and-highlight-in-file
|
|
(list (make-srcloc src #f #f pos span))))))
|
|
|
|
(define interactions-text-mixin
|
|
(mixin ((class->interface drscheme:rep:text%)) ()
|
|
(inherit get-user-namespace)
|
|
(super-new)
|
|
|
|
(define/private (setup-helper-module)
|
|
(let ([link (parameterize ((current-namespace (get-user-namespace)))
|
|
(dynamic-require LINK-MODULE-SPEC 'link))])
|
|
(set-box! link (vector get-errortrace-backtrace
|
|
show-backtrace
|
|
show-source))))
|
|
|
|
(define/override (reset-console)
|
|
(super reset-console)
|
|
(setup-helper-module))))
|
|
|
|
(drscheme:get/extend:extend-interactions-text interactions-text-mixin)
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2) (void))
|
|
|
|
))
|