plt/gui/drscheme-ui-tool.ss
;; drscheme-ui-tool
(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@)

  ;; CONSTANTS

  (define BACKTRACE-NO-MESSAGE "No message.")
  (define UI-MODULE-SPEC
    `(,(#%info-lookup 'distribution-method)
       "plt/gui/drscheme-ui.ss"
       ,(#%info-lookup 'distribution-package-spec)))

  ;; / CONSTANTS

  ;; 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^)

      ;; Try loading now, to provoke error at tool load time
      ;; rather than execution time; if error occurs at tool
      ;; load time, DrScheme unloads the tool.
      (dynamic-require UI-MODULE-SPEC #f)

      ;; 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)
        #|
        ;; cm-key no longer available
        (let ([cms (continuation-mark-set->list
                    (exn-continuation-marks exn)
                    (drscheme:debug:get-cm-key))])
          (map list->srcloc cms))
        |#
        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))))))

      ;; Send them off to the drscheme-ui module.
      ;; We'll still have to attach this instantiation of drscheme-ui to
      ;; the user namespace.
      (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))

      ))
  )