(module drscheme-ui-tool mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "tool.ss" "drscheme")
(lib "unit.ss"))
(require (prefix drlink: "drscheme-ui.ss")
"../../info.ss")
(provide tool@)
(define BACKTRACE-NO-MESSAGE "No message.")
(define UI-MODULE-SPEC
`(,(#%info-lookup 'distribution-method)
"plt/gui/drscheme-ui.ss"
,(#%info-lookup 'distribution-package-spec)))
(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^)
(dynamic-require UI-MODULE-SPEC #f)
(define show-backtrace
(close-eventspace/async
(lambda (msg srclocs)
(drscheme:debug:show-backtrace-window
(or msg BACKTRACE-NO-MESSAGE)
srclocs))))
(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)
(let ([cms (continuation-mark-set->list
(exn-continuation-marks exn)
(drscheme:debug:get-cm-key))])
(map list->srcloc cms)))
(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))))))
(drlink:initialize get-errortrace-backtrace
show-backtrace
show-source)
(define interactions-text-mixin
(mixin ((class->interface drscheme:rep:text%)) ()
(define/private (setup-helper-module)
(let ((drscheme-ns (current-namespace))
(user-ns (send this get-user-namespace)))
(parameterize ((current-namespace user-ns))
((dynamic-require UI-MODULE-SPEC 'initialize)
get-errortrace-backtrace
show-backtrace
show-source))))
(define/override (reset-console)
(super reset-console)
(setup-helper-module))
(super-instantiate ())))
(drscheme:get/extend:extend-interactions-text interactions-text-mixin)
(define (phase1) (void))
(define (phase2) (void))
))
)