;; drscheme-ui
;; Procedures which *may* be overridden by DrScheme to do useful things.
;; Or they may not be.

(module drscheme-ui mzscheme
  (require (lib "list.ss")
           (lib "string.ss")
           (lib "etc.ss"))

  (provide has-backtrace?
           has-errortrace-backtrace?
           has-primitive-backtrace?
           show-errortrace-backtrace
           show-primitive-backtrace
           can-show-source?
           show-source
           initialized?

           ;; Only for use by DrScheme tool code.
           initialize)

  ;; A Backtrace is one of
  ;;   - exn
  ;;   - (listof srcloc)

  (define USE-PRIMITIVE-STACKTRACE? #t)

  ;; has-backtrace? : exn -> boolean
  (define (has-backtrace? exn)
    (or (has-errortrace-backtrace? exn)
        (has-primitive-backtrace? exn)))

  ;; has-errortrace-backtrace? : exn -> boolean
  (define (has-errortrace-backtrace? exn)
    (not (null? (get-errortrace-backtrace exn))))

  ;; has-primitive-backtrace? : exn -> boolean
  (define (has-primitive-backtrace? exn)
    (and USE-PRIMITIVE-STACKTRACE?
         (pair? (get-primitive-backtrace exn))))

  ;; get-errortrace-backtrace : exn -> Backtrace
  (define (get-errortrace-backtrace exn)
    null)

  ;; get-primitive-backtrace : exn -> Backtrace
  (define (get-primitive-backtrace exn)
    (let* ([ctx (continuation-mark-set->context
                 (exn-continuation-marks exn))]
           [srclocs (map cdr ctx)])
      (filter (lambda (s)
                (and (srcloc? s)
                     (let ([src (srcloc-source s)])
                       (and (path? src)
                            (not (regexp-match?
                                  (regexp-quote
                                   (path->string
                                    (this-expression-source-directory)))
                                  (path->string src)))))))
              srclocs)))

  ;; show-errortrace-backtrace : exn -> void
  (define (show-errortrace-backtrace exn)
    (show-backtrace (exn-message exn)
                    (get-errortrace-backtrace exn)))

  ;; show-primitive-backtrace : exn -> void
  (define (show-primitive-backtrace exn)
    (show-backtrace (exn-message exn)
                    (get-primitive-backtrace exn)))

  ;; can-show-source? : boolean
  (define can-show-source? #f)

  ;; show-source : source number number -> void
  (define (show-source src pos span) (void))

  ;; ----

  (define (show-backtrace msg bt) (void))

  (define initialized? #f)
  (define (initialize -get-errortrace-backtrace -show-backtrace -show-source)
    (unless initialized?
      (set! get-errortrace-backtrace -get-errortrace-backtrace)
      (set! show-backtrace -show-backtrace)
      (set! can-show-source? #t)
      (set! show-source -show-source)
      (set! initialized? #t)))
  )