#lang racket/base

#|

profile todo:
  - use origin fields
  - sort out various ways of clearing out the profiling information

|#

(require errortrace/errortrace-key
         racket/unit
         racket/contract
         errortrace/stacktrace
         racket/class
         racket/path
         racket/gui/base
         string-constants
         framework
         framework/private/bday
         "embedded-snip-utils.rkt"
         "drsig.rkt"
         "bindings-browser.rkt"
         net/sendurl
         net/url
         racket/match
         mrlib/include-bitmap
         (for-syntax racket/base))

(define orig (current-output-port))
(define (oprintf . args) (apply fprintf orig args))

(provide debug@)
(define-unit debug@
  (import [prefix drracket:rep: drracket:rep^]
          [prefix drracket:frame: drracket:frame^]
          [prefix drracket:unit: drracket:unit^]
          [prefix drracket:language: drracket:language^]
          [prefix drracket:language-configuration: drracket:language-configuration/internal^]
          [prefix drracket:init: drracket:init^])
  (export drracket:debug^)
  
  ;                                                          
  ;                                                          
  ;   ;                                                      
  ;   ;                             ;                        
  ;   ;                                                      
  ;   ; ;;   ;   ;   ;; ;         ;;;     ;;;;   ;;;   ; ;;  
  ;   ;;  ;  ;   ;  ;  ;;           ;    ;      ;   ;  ;;  ; 
  ;   ;   ;  ;   ;  ;   ;           ;    ;      ;   ;  ;   ; 
  ;   ;   ;  ;   ;  ;   ;           ;    ;      ;   ;  ;   ; 
  ;   ;   ;  ;   ;  ;   ;           ;    ;      ;   ;  ;   ; 
  ;   ;;  ;  ;  ;;  ;  ;;           ;    ;      ;   ;  ;   ; 
  ;   ; ;;    ;; ;   ;; ;           ;     ;;;;   ;;;   ;   ; 
  ;                     ;                                    
  ;                  ;;;                                     
  ;                                                          
  
  ;; type debug-source = (union symbol (instanceof editor<%>))
  
  ;; original-output-port : output-port
  ;; for debugging -- be sure to print to here, not the current output port
  (define original-output-port (current-output-port))
  
  ;; cms->srclocs : continuation-marks -> (listof srcloc)
  (define (cms->srclocs cms)
    (map 
     (λ (x) (make-srcloc (list-ref x 1)
                         (list-ref x 2)
                         (list-ref x 3)
                         (list-ref x 4)
                         (list-ref x 5)))
     (continuation-mark-set->list cms errortrace-key)))
  
  ;; error-delta : (instanceof style-delta%)
  (define error-delta (make-object style-delta% 'change-style 'italic))
  (send error-delta set-delta-foreground (make-object color% 255 0 0))
  
  ;; get-error-color : -> (instanceof color%)
  (define get-error-color
    (let ([w-o-b (make-object color% 63 0 0)]
          [b-o-w (make-object color% "PINK")])
      (λ ()
        (if (preferences:get 'framework:white-on-black?)
            w-o-b
            b-o-w))))
  
  (define arrow-cursor (make-object cursor% 'arrow))
  (define (clickable-snip-mixin snip%)
    (class snip%
      (init-rest args)
      (inherit get-flags set-flags get-admin get-extent)
      
      (define callback void)
      (define/public (set-callback cb) (set! callback cb))
      (define/public (get-callback) callback)
      
      (define in-bounds? #f)
      (define grabbed? #f)
      
      (define (set-clicked new-grabbed? new-in-bounds? dc)
        (let ([needs-invalidate? (not (eq? (and grabbed? in-bounds?)
                                           (and new-grabbed? new-in-bounds?)))])
          (set! grabbed? new-grabbed?)
          (set! in-bounds? new-in-bounds?)
          (when needs-invalidate?
            (invalidate dc))))
      
      (define/override (draw dc x y left top right bottom dx dy draw-caret)
        (super draw dc x y left top right bottom dx dy draw-caret)
        (when (and in-bounds? grabbed?)
          (let ([brush (send dc get-brush)]
                [pen (send dc get-pen)])
            (let-values ([(w h) (get-w/h dc)])
              (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite))
              (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
              (send dc draw-rectangle x y w h)
              (send dc set-pen pen)
              (send dc set-brush brush)))))
      
      (define/override (on-event dc x y editorx editory evt)
        (let-values ([(w h) (get-w/h dc)])
          (let ([in-bounds? (and (<= (- (send evt get-x) x) w)
                                 (<= (- (send evt get-y) y) h))])
            (cond
              [(send evt button-down? 'left)
               (set-clicked #t in-bounds? dc)]
              [(send evt button-up? 'left)
               (let ([admin (send this get-admin)])
                 (when admin
                   (send (send admin get-editor) set-caret-owner #f 'global)))
               (when (and grabbed? in-bounds?)
                 (callback))
               (set-clicked #f in-bounds? dc)]
              [else
               (set-clicked grabbed? in-bounds? dc)]))))
      
      (define/private (invalidate dc)
        (let ([admin (get-admin)])
          (when admin
            (let-values ([(w h) (get-w/h dc)])
              (send admin needs-update this 0 0 w h)))))
      
      (define/private (get-w/h dc)
        (let ([wb (box 0)]
              [hb (box 0)])
          ;; know that the snip is the same size everywhere, 
          ;; so just use (0,0) for its position
          (get-extent dc 0 0 wb hb #f #f #f #f)
          (values (unbox wb)
                  (unbox hb))))
      
      (define/override (adjust-cursor dc x y editorx editory event)
        arrow-cursor)
      
      (apply super-make-object args)
      (set-flags (cons 'handles-events (get-flags)))))
  
  (define clickable-image-snip%  (clickable-snip-mixin image-snip%))
  (define clickable-string-snip%  
    (class (clickable-snip-mixin string-snip%)
      (inherit get-callback set-callback)
      (init-field str)
      (define/override (copy)
        (let ([n (new clickable-string-snip% [str str])])
          (send n set-callback (get-callback))
          n))
      (super-make-object str)))
  
  ;; make-note% : string -> (union class #f)
  (define (make-note% filename bitmap)
    (and (send bitmap ok?)
         (letrec ([note%
                   (class clickable-image-snip%
                     (inherit get-callback)
                     (define/public (get-image-name) filename)
                     (define/override (copy) 
                       (let ([n (new note%)])
                         (send n set-callback (get-callback))
                         n))
                     (super-make-object bitmap))])
           note%)))
  
  (define bug-note% (make-note% "stop-multi.png" (include-bitmap (lib "icons/stop-multi.png") 'png/mask)))
  (define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif)))
  (define file-note% (make-note% "stop-22x22.png" (include-bitmap (lib "icons/stop-22x22.png") 'png/mask)))
  (define small-planet-bitmap (include-bitmap (lib "icons/small-planet.png") 'png/mask))
  (define planet-note% (make-note% "small-planet.png" small-planet-bitmap))
  
  ;; display-stats : (syntax -> syntax)
  ;; count the number of syntax expressions & number of with-continuation-marks in an 
  ;; expanded expression ... except that it counts keywords, too.
  ;; returns its argument.
  ;(define (display-stats stx)
  ;  (let ([exps 0]
  ;        [wcms 0])
  ;    (let loop ([stx stx])
  ;      (kernel-syntax-case stx ()
  ;        [(#%with-continuation-mark key mark body)
  ;         (set! wcms (+ wcms 1))
  ;         (loop #`body)]
  ;        [(subexps ...)
  ;         (set! exps (+ exps 1))
  ;         (for-each loop (syntax->list stx))]
  ;        [exp
  ;         (set! exps (+ exps 1))]))
  ;    (fprintf (current-error-port) "exps: ~v\nwcms: ~v\n" exps wcms))
  ;  stx)
  
  ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value
  ;; adds debugging information to `sexp' and calls `oe'
  (define (make-debug-eval-handler oe)
    (let ([debug-tool-eval-handler
           (λ (orig-exp)
             (if (compiled-expression? (if (syntax? orig-exp)  
                                           (syntax-e orig-exp)  
                                           orig-exp))
                 (oe orig-exp)
                 (let loop ([exp (if (syntax? orig-exp)
                                     orig-exp
                                     (namespace-syntax-introduce
                                      (datum->syntax #f orig-exp)))])
                   (let ([top-e (expand-syntax-to-top-form exp)]) 
                     (syntax-case top-e (begin) 
                       [(begin expr ...)
                        ;; Found a `begin', so expand/eval each contained 
                        ;; expression one at a time 
                        (let i-loop ([exprs (syntax->list #'(expr ...))]
                                     [last-one (list (void))])
                          (cond
                            [(null? exprs) 
                             (apply values last-one)]
                            [else 
                             (i-loop (cdr exprs)
                                     (call-with-values 
                                      (λ () 
                                        (call-with-continuation-prompt
                                         (λ () (loop (car exprs)))
                                         (default-continuation-prompt-tag)
                                         (λ args
                                           (apply
                                            abort-current-continuation 
                                            (default-continuation-prompt-tag)
                                            args))))
                                      list))]))]
                       [_else 
                        ;; Not `begin', so proceed with normal expand and eval 
                        (let* ([annotated (annotate-top (expand-syntax top-e)
                                                        (namespace-base-phase))])
                          (oe annotated))])))))])
      debug-tool-eval-handler))
  
  ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void
  ;; adds in the bug icon, if there are contexts to display
  (define (make-debug-error-display-handler orig-error-display-handler)
    (define (debug-error-display-handler msg exn)
      (let ([rep (drracket:rep:current-rep)])
        (cond
          [rep
           (error-display-handler/stacktrace 
            msg
            exn 
            (and (exn? exn) 
                 (continuation-mark-set? (exn-continuation-marks exn))
                 (cms->srclocs (exn-continuation-marks exn))))]
          [else 
           (orig-error-display-handler msg exn)])))
    debug-error-display-handler)
  
  ;; error-display-handler/stacktrace : string any (listof srcloc) -> void
  ;; =User=
  (define (error-display-handler/stacktrace 
           msg exn 
           [pre-stack #f]
           #:interactions-text [ints (drracket:rep:current-rep)]
           #:definitions-text [defs (let ([rep (drracket:rep:current-rep)])
                                      (and rep
                                           (send rep get-definitions-text)))])
                                                                     
    (let* ([stack (or pre-stack
                      (if (exn? exn)
                          (map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn))))
                          '()))]
           [src-locs (if (exn:srclocs? exn)
                         ((exn:srclocs-accessor exn) exn)
                         (if (null? stack)
                             '()
                             (list (car stack))))]
           [stack-editions (map (λ (x) (srcloc->edition/pair defs ints x)) stack)]
           [src-locs-edition (and (pair? src-locs)
                                  (srcloc->edition/pair defs ints (car src-locs)))])
      (print-planet-icon-to-stderr exn)
      (unless (null? stack)
        (print-bug-to-stderr msg stack stack-editions defs ints))
      (display-srclocs-in-error src-locs src-locs-edition)
      (display msg (current-error-port))
      (when (exn:fail:syntax? exn)
        (unless (error-print-source-location)
          (show-syntax-error-context (current-error-port) exn)))
      (newline (current-error-port))
      (flush-output (current-error-port))
      (when (and ints
                 (eq? (current-error-port) 
                      (send ints get-err-port)))
        (parameterize ([current-eventspace drracket:init:system-eventspace])
          (queue-callback
           (λ ()
             ;; need to make sure that the user's eventspace is still the same
             ;; and still running here?
             (send ints highlight-errors src-locs stack)))))))
  
  (define (srcloc->edition/pair defs ints srcloc)
    (let ([src (srcloc-source srcloc)])
      (cond
        [(and (or (symbol? src)
                  (path? src))
              ints
              (send ints port-name-matches? src))
         (cons (make-weak-box ints) (send ints get-edition-number))]
        [(and (or (symbol? src)
                  (path? src))
              defs
              (send defs port-name-matches? src))
         (cons (make-weak-box defs) (send defs get-edition-number))]
        [(path? src)
         (let ([frame (send (group:get-the-frame-group) locate-file src)])
           (and frame
                (is-a? frame drracket:unit:frame<%>)
                (cons (make-weak-box (send frame get-definitions-text))
                      (send (send frame get-definitions-text) get-edition-number))))]
        [else #f])))
  
  ;; =User=
  (define (print-planet-icon-to-stderr exn)
    (when (exn:fail:contract:blame? exn)
      (let ([table (parse-gp exn
                             (blame-positive
                              (exn:fail:contract:blame-object exn)))])
        (when table
          (let ([gp-url (bug-info->ticket-url table)])
            (when planet-note%
              (when (port-writes-special? (current-error-port))
                (let ([note (new planet-note%)])
                  (send note set-callback (λ () 
                                            ;; =Kernel= =Handler=
                                            (drracket:unit:forget-saved-bug-report table)
                                            (send-url (url->string gp-url))))
                  (parameterize ([current-eventspace drracket:init:system-eventspace])
                    (queue-callback
                     (λ ()
                       (drracket:unit:record-saved-bug-report table))))
                  (write-special note (current-error-port))
                  (display #\space (current-error-port))))))))))
  
  ;; =Kernel= =User=
  (define (bug-info->ticket-url table)
    (make-url 
     "http"
     #f
     "planet.racket-lang.org"
     #f
     #t
     (list (make-path/param "trac" '())
           (make-path/param "newticket" '()))
     table
     #f))
  
  ;; =User=
  (define (parse-gp exn gp)
    (match gp
      [`(planet ,fn (,user ,package ,planet-version ...))
       (list (cons 'component (format "~a/~a" user package))
             (cons 'keywords "contract violation")
             (cons 'pltversion (version))
             (cons 'planetversion
                   (cond
                     [(null? planet-version) ""]
                     [(null? (cdr planet-version))
                      (format "~s" `(,(car planet-version) ?))]
                     [else
                      (format "~s" `(,(car planet-version) ,(cadr planet-version)))]))
             (cons 'description (exn->trace exn)))]
      [else #f]))
  
  ;; =User=
  (define (exn->trace exn)
    (let ([sp (open-output-string)])
      (parameterize ([current-error-port sp])
        (drracket:init:original-error-display-handler (exn-message exn) exn))
      (get-output-string sp)))
  
  ;; =User=
  (define (print-bug-to-stderr msg cms editions defs ints)
    (when (port-writes-special? (current-error-port))
      (let ([note% (if (mf-bday?) mf-note% bug-note%)])
        (when note%
          (let ([note (new note%)])
            (send note set-callback (λ () (show-backtrace-window/edition-pairs msg cms editions defs ints)))
            (write-special note (current-error-port))
            (display #\space (current-error-port)))))))
  
  ;; display-srclocs-in-error : (listof src-loc) -> void
  ;; prints out the src location information for src-to-display
  ;; as it would appear in an error message
  (define (display-srclocs-in-error srcs-to-display edition-pair)
    (unless (null? srcs-to-display)
      (let ([src-to-display (car srcs-to-display)])
        (let* ([src (srcloc-source src-to-display)]
               [line (srcloc-line src-to-display)]
               [col (srcloc-column src-to-display)]
               [pos (srcloc-position src-to-display)]
               [do-icon
                (λ ()
                  (when file-note%
                    (when (port-writes-special? (current-error-port))
                      (let ([note (new file-note%)])
                        (send note set-callback 
                              (λ () (open-and-highlight-in-file srcs-to-display edition-pair)))
                        (write-special note (current-error-port))
                        (display #\space (current-error-port))))))]
               [do-src
                (λ ()
                  (cond
                    [(path? src)
                     (display (path->string (find-relative-path (current-directory)
                                                                (normalize-path src)))
                              (current-error-port))]
                    [else
                     (display "<unsaved editor>" (current-error-port))]))]
               [do-line/col (λ () (fprintf (current-error-port) ":~a:~a" line col))]
               [do-pos (λ () (fprintf (current-error-port) "::~a" pos))]
               [src-loc-in-defs/ints?
                (let ([rep (drracket:rep:current-rep)])
                  (and rep
                       (is-a? rep drracket:rep:text<%>)
                       (let ([defs (send rep get-definitions-text)])
                         (or (send rep port-name-matches? src)
                             (eq? rep src)
                             (send defs port-name-matches? src)
                             (eq? defs src)))))])
          (cond
            [(and src line col)
             (do-icon)
             (unless src-loc-in-defs/ints?
               (do-src)
               (do-line/col)
               (display ": " (current-error-port)))]
            [(and src pos)
             (do-icon)
             (unless src-loc-in-defs/ints?
               (do-src)
               (do-pos)
               (display ": " (current-error-port)))])))))
  
  ;; find-src-to-display : exn (union #f (listof srcloc))
  ;;                    -> (listof srclocs)
  ;; finds the source location to display, choosing between
  ;; the stack trace and the exception record.
  (define (find-src-to-display exn cms)
    (let ([has-info?
           (λ (srcloc)
             (ormap (λ (f) (f srcloc))
                    (list srcloc-column
                          srcloc-line
                          srcloc-position
                          srcloc-source
                          #;srcloc-span)))])  ;; don't consider span alone to count as `info'
      (cond
        [(and (exn:srclocs? exn)
              (ormap has-info? ((exn:srclocs-accessor exn) exn)))
         ((exn:srclocs-accessor exn) exn)]
        [(pair? cms) (list (car cms))]
        [else '()])))
  
  ;; show-syntax-error-context : 
  ;; display the source information associated with a syntax error (if present)
  (define (show-syntax-error-context port exn)
    (let ([error-text-style-delta (make-object style-delta%)]
          [send-out
           (λ (msg f) 
             (if (port-writes-special? (current-error-port))
                 (let ([snp (make-object string-snip% msg)])
                   (f snp)
                   (write-special snp (current-error-port)))
                 (display msg (current-error-port))))])
      (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0))
      (let ([show-one
             (λ (expr)
               (display " " (current-error-port))
               (send-out (format "~s" (syntax->datum expr))
                         (λ (snp)
                           (send snp set-style
                                 (send the-style-list find-or-create-style
                                       (send snp get-style)
                                       error-text-style-delta)))))]
            [exprs (exn:fail:syntax-exprs exn)])
        (cond
          [(null? exprs) (void)]
          [(null? (cdr exprs))
           (send-out " in:" void)
           (show-one (car exprs))]
          [else
           (send-out " in:" void)
           (for-each (λ (expr)
                       (display "\n " (current-error-port))
                       (show-one expr))
                     exprs)]))))
  
  
  ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void)
  ;; inserts `note' and a space at the end of `rep'
  ;; also sets a clickback on the inserted `note' (but not the space).
  (define (insert/clickback rep note clickback)
    (let ([before (send rep last-position)])
      (send rep insert (if (string? note)
                           note
                           (send note copy))
            before before)
      (let ([after (send rep last-position)])
        (send rep insert #\space after after)
        (send rep set-clickback before after
              (λ (txt start end)
                (clickback))))))
  
  ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax
  ;; a member of stacktrace-imports^
  ;; guarantees that the continuation marks associated with errortrace-key are
  ;; members of the debug-source type, after unwrapped with st-mark-source
  (define (with-mark src-stx expr)
    (let ([source (cond
                    [(path? (syntax-source src-stx))
                     (syntax-source src-stx)]
                    [(is-a? (syntax-source src-stx) editor<%>)
                     (syntax-source src-stx)]
                    [else 
                     (let* ([rep (drracket:rep:current-rep)])
                       (and
                        rep
                        (let ([defs (send rep get-definitions-text)])
                          (cond
                            [(send rep port-name-matches? (syntax-source src-stx))
                             rep]
                            [(send defs port-name-matches? (syntax-source src-stx))
                             defs]
                            [else #f]))))])]
          [position (or (syntax-position src-stx) 0)]
          [span (or (syntax-span src-stx) 0)]
          [line (or (syntax-line src-stx) 0)]
          [column (or (syntax-column src-stx) 0)])
      (if source
          (with-syntax ([expr expr]
                        [mark (list 'dummy-thing source line column position span)]
                        [errortrace-key errortrace-key])
            (syntax
             (with-continuation-mark 'errortrace-key
               'mark
               expr)))
          expr)))
  
  ;; current-backtrace-window : (union #f (instanceof frame:basic<%>))
  ;; the currently visible backtrace window, or #f, if none
  (define current-backtrace-window #f)
  
  ;; reset-backtrace-window : -> void
  ;; effect: updates current-backtrace-window
  ;; closes the current backtrace window and creates a new (unshown) one
  (define (reset-backtrace-window)
    (when current-backtrace-window
      (send current-backtrace-window close)
      (set! current-backtrace-window #f))
    
    (set! current-backtrace-window 
          (make-object backtrace-frame%
            (string-constant backtrace-window-title)
            #f
            (preferences:get 'drracket:backtrace-window-width)
            (preferences:get 'drracket:backtrace-window-height)
            (preferences:get 'drracket:backtrace-window-x)
            (preferences:get 'drracket:backtrace-window-y))))
  
  ;; hide-backtrace-window : -> void
  (define (hide-backtrace-window)
    (when current-backtrace-window
      (send current-backtrace-window close)
      (set! current-backtrace-window #f)))
  
  ;; backtrace-frame% : (extends frame:basic<%>)
  (define backtrace-frame%
    (class (drracket:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
      (define/override (on-size x y)
        (preferences:set 'drracket:backtrace-window-width x)
        (preferences:set 'drracket:backtrace-window-height y)
        (super on-size x y))
      (define/override (on-move x y)
        (preferences:set 'drracket:backtrace-window-x x)
        (preferences:set 'drracket:backtrace-window-y y)
        (super on-move x y))
      (define/override (edit-menu:between-find-and-preferences edit-menu) (void))
      (define/override (edit-menu:between-select-all-and-find edit-menu) (void))
      (define/override (file-menu:between-save-as-and-print file-menu) (void))
      (define/augment (on-close) 
        (set! current-backtrace-window #f)
        (inner (void) on-close))
      (super-new)))
  
  ;; show-backtrace-window : string
  ;;                         (listof srcloc?)
  ;;                         -> 
  ;;                         void
  (define (show-backtrace-window error-text dis/exn [rep #f] [defs #f])
    (let ([dis (if (exn? dis/exn)
                   (cms->srclocs (exn-continuation-marks dis/exn))
                   dis/exn)])
    (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep)))
  
  (define (show-backtrace-window/edition-pairs error-text dis editions defs ints)
    (reset-backtrace-window)
    (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
             [mf-bday-note (when (mf-bday?)
                             (instantiate message% ()
                               (label (string-constant happy-birthday-matthias))
                               (parent (send current-backtrace-window get-area-container))))]
             [ec (make-object (canvas:color-mixin canvas:wide-snip%)
                   (send current-backtrace-window get-area-container)
                   text)]
             [di-vec (list->vector dis)]
             [editions-vec (list->vector editions)]
             [index 0]
             [how-many-at-once 15]
             [show-next-dis
              (λ ()
                (let ([start-pos (send text get-start-position)]
                      [end-pos (send text get-end-position)])
                  (send text begin-edit-sequence)
                  (send text set-position (send text last-position))
                  (let loop ([n index])
                    (cond
                      [(and (< n (vector-length di-vec))
                            (< n (+ index how-many-at-once)))
                       (show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) defs ints)
                       (loop (+ n 1))]
                      [else
                       (set! index n)]))
                  
                  ;; add 'more frames' link
                  (when (< index (vector-length di-vec))
                    (let ([end-of-current (send text last-position)])
                      (send text insert #\newline)
                      (let ([hyper-start (send text last-position)])
                        (send text insert 
                              (let* ([num-left
                                      (- (vector-length di-vec)
                                         index)]
                                     [num-to-show
                                      (min how-many-at-once
                                           num-left)])
                                (if (= num-left 1)
                                    (string-constant last-stack-frame)
                                    (format (if (num-left . <= . num-to-show)
                                                (string-constant last-stack-frames)
                                                (string-constant next-stack-frames))
                                            num-to-show))))
                        (let ([hyper-end (send text last-position)])
                          (send text change-style (gui-utils:get-clickback-delta
                                                   (preferences:get 'framework:white-on-black?))
                                hyper-start hyper-end)
                          (send text set-clickback
                                hyper-start hyper-end
                                (λ x
                                  (send text begin-edit-sequence)
                                  (send text lock #f)
                                  (send text delete end-of-current (send text last-position))
                                  (show-next-dis)
                                  (send text set-position 
                                        (send text last-position)
                                        (send text last-position))
                                  (send text lock #t)
                                  (send text end-edit-sequence)))
                          
                          (send text insert #\newline)
                          (send text set-paragraph-alignment (send text last-paragraph) 'center)))))
                  
                  (send text set-position start-pos end-pos)
                  (send text end-edit-sequence)))])
      (send current-backtrace-window set-alignment 'center 'center)
      (send current-backtrace-window reflow-container)
      (send text auto-wrap #t)
      (send text set-autowrap-bitmap #f)
      (send text insert error-text)
      (send text insert "\n\n")
      (send text change-style error-delta 0 (- (send text last-position) 1))
      (show-next-dis)
      (send text set-position 0 0)
      (send text lock #t)
      (send text hide-caret #t)
      (send current-backtrace-window show #t)))
  
  ;; show-frame : (instanceof editor-canvas%)
  ;;              (instanceof text%) 
  ;;              st-mark?
  ;;              def ints  // definitions and interactions texts
  ;;              -> 
  ;;              void 
  ;; shows one frame of the continuation
  (define (show-frame editor-canvas text di edition defs ints)
    (let* ([debug-source (srcloc-source di)]
           [fn (get-filename debug-source)]
           [line (srcloc-line di)]
           [column (srcloc-column di)]
           [start (srcloc-position di)]
           [span (srcloc-span di)]
           [start-pos (send text last-position)])
      
      ;; make hyper link to the file
      (send text insert (format "~a: ~a:~a" fn line column))
      (let ([end-pos (send text last-position)])
        (send text insert " ")
        (send text change-style 
              (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?))
              start-pos 
              end-pos)
        (send text set-clickback
              start-pos end-pos
              (λ (ed start end)
                (open-and-highlight-in-file (list di) edition))))
      
      ;; make bindings hier-list
      (let ([bindings (st-mark-bindings di)])
        (when (not (null? bindings))
          (send text insert (render-bindings/snip bindings))))
      (send text insert #\newline)
      
      (insert-context editor-canvas text debug-source start span defs ints)
      (send text insert #\newline)))
  
  ;; insert-context : (instanceof editor-canvas%)
  ;;                  (instanceof text%)
  ;;                  debug-info
  ;;                  number
  ;;                  defs ints // definitions and interactions texts
  ;;                  -> 
  ;;                  void
  (define (insert-context editor-canvas text file start span defs ints)
    (let-values ([(from-text close-text)
                  (cond
                    [(and ints (send ints port-name-matches? file))
                     (values ints void)]
                    [(and defs (send defs port-name-matches? file))
                     (values defs void)]
                    [(path? file)
                     (let ([file (with-handlers ((exn:fail? (λ (x) #f)))
                                   (normal-case-path (normalize-path file)))])
                       (if file
                           (cond
                             [(send (group:get-the-frame-group)
                                    locate-file
                                    file)
                              =>
                              (λ (frame)
                                (cond
                                  [(is-a? frame drracket:unit:frame%)
                                   (let loop ([tabs (send frame get-tabs)])
                                     (cond
                                       [(null? tabs) (values #f void)]
                                       [else
                                        (let* ([tab (car tabs)]
                                               [defs (send tab get-defs)])
                                          (if (with-handlers ((exn:fail? (λ (x) #f)))
                                                (equal? (normalize-path (normal-case-path (send defs get-filename)))
                                                        file))
                                              (values defs void)
                                              (loop (cdr tabs))))]))]
                                  [(is-a? frame frame:editor<%>)
                                   (values (send frame get-editor) void)]
                                  [else (values #f void)]))]
                             [(path? file)
                              (let ([text (new text:basic%)])
                                (if (send text load-file file)
                                    (values text 
                                            (λ () (send text on-close)))
                                    (values #f (λ () (void)))))]
                             [else
                              (values #f void)])
                           (values #f void)))]
                    [(is-a? file editor<%>)
                     (values file void)]
                    [else (error 'insert-context "unknown file spec ~e" file)])])
      (when from-text
        (let* ([finish (+ start span -1)]
               [context-text (copy/highlight-text from-text start finish)])
          (send context-text lock #t)
          (send context-text hide-caret #t)
          (send text insert "  ")
          (let ([snip (make-object editor-snip% context-text)])
            (send snip use-style-background #t)
            (send editor-canvas add-wide-snip snip)
            (let ([p (send text last-position)])
              (send text insert snip p p)
              (send text insert #\newline)
              (when (preferences:get 'framework:white-on-black?)
                (send text change-style white-on-black-style p (+ p 1))))))
        (close-text))))
  
  (define white-on-black-style (make-object style-delta%))
  (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white"))
  
  ;; copy/highlight-text : text number number -> text
  ;; copies the range from `start' to `finish', including the entire paragraph at
  ;; each end and highlights the characters corresponding the original range,
  ;; in the resulting text
  (define (copy/highlight-text from-text start finish)
    (let* ([to-text (new text:standard-style-list%)]
           [para-start-pos (send from-text paragraph-start-position 
                                 (send from-text position-paragraph start))]
           [para-end-pos (send from-text paragraph-end-position
                               (send from-text position-paragraph 
                                     finish))]
           [from-start (- start para-start-pos)]
           [from-end (+ from-start (- finish start))])
      (send from-text split-snip para-start-pos)
      (send from-text split-snip para-end-pos)
      (let loop ([snip (send from-text find-snip para-start-pos 'after-or-none)])
        (when (and snip
                   (< (send from-text get-snip-position snip) para-end-pos))
          (send to-text insert (send snip copy))
          (loop (send snip next))))
      (send to-text highlight-range (max 0 (- from-start 1)) from-end (get-error-color) #f 'high)
      to-text))
  
  ;; get-filename : debug-source -> string
  (define (get-filename file)
    (cond
      [(symbol? file) (symbol->string file)]
      [(path? file) (path->string file)]
      [(is-a? file editor<%>)
       (get-filename-from-editor file)]))
  
  ;; get-filename-from-editor : (is-a?/c editor<%>) -> string
  (define (get-filename-from-editor editor)
    (let* ([untitled (string-constant unknown-debug-frame)]
           [canvas (send editor get-canvas)]
           [frame (and canvas (send canvas get-top-level-window))])
      (if (is-a? frame drracket:unit:frame%)
          (let ([filename (send (send frame get-definitions-text) get-filename)])
            (cond
              [(and filename (eq? editor (send frame get-interactions-text)))
               (format (string-constant files-interactions) filename)]
              [(eq? editor (send frame get-interactions-text))
               (string-constant current-interactions)]
              [filename filename]
              [else (string-constant current-definitions)]))
          (or (send editor get-filename) 
              untitled))))
  
  ;; open-and-highlight-in-file : (or/c srcloc (listof srcloc)) -> void
  (define (open-and-highlight-in-file raw-srcloc [edition-pair #f])
    (let* ([srclocs (if (srcloc? raw-srcloc) (list raw-srcloc) raw-srcloc)]
           [sources (filter values (map srcloc-source srclocs))])
      (unless (null? sources)
        (let* ([debug-source (car sources)]
               [same-src-srclocs
                (filter (λ (x) (eq? debug-source (srcloc-source x)))
                        srclocs)]
               [frame (cond
                        [(path? debug-source) (handler:edit-file debug-source)]
                        [(and (symbol? debug-source)
                              (text:lookup-port-name debug-source))
                         =>
                         (lambda (editor)
                           (get-enclosing-editor-frame editor))]
                        [else #f])]
               [editor (cond
                         [(path? debug-source)
                          (cond
                            [(and frame (is-a? frame drracket:unit:frame%))
                             (send frame get-definitions-text)]
                            [(and frame (is-a? frame frame:editor<%>))
                             (send frame get-editor)]
                            [else #f])]
                         [(and (symbol? debug-source)
                               (text:lookup-port-name debug-source))
                          =>
                          values]
                         [else #f])]
               [rep (and (is-a? frame drracket:unit:frame%)
                         (send frame get-interactions-text))])
          (when frame
            (send frame show #t))
          (when (and edition-pair
                     (let ([wbv (weak-box-value (car edition-pair))])
                       (and wbv (eq? editor wbv))))
            (unless (= (cdr edition-pair) (send editor get-edition-number))
              (message-box (string-constant drscheme)
                           (string-constant editor-changed-since-srcloc-recorded)
                           frame
                           '(ok caution))))
          (when (and rep editor)
            (when (is-a? editor text:basic<%>)
              (send rep highlight-errors same-src-srclocs '())
              (send editor set-caret-owner #f 'global)))))))
  
  
  
  
  ;                                                                                      
  ;                                                                                      
  ;                                                                                      
  ;                                                                                      
  ;                                                                                      
  ;   ;                  ;                                                               
  ;  ;;;;   ;;;    ;;;  ;;;;       ;;;    ;;;   ;     ;  ;;;   ; ;  ;;;     ;; ;    ;;;  
  ;   ;    ;   ;  ;      ;        ;   ;  ;   ;   ;   ;  ;   ;  ;;  ;   ;   ;  ;;   ;   ; 
  ;   ;   ;    ;  ;;     ;       ;      ;     ;  ;   ; ;    ;  ;       ;  ;    ;  ;    ; 
  ;   ;   ;;;;;;   ;;    ;       ;      ;     ;   ; ;  ;;;;;;  ;    ;;;;  ;    ;  ;;;;;; 
  ;   ;   ;          ;   ;       ;      ;     ;   ; ;  ;       ;   ;   ;  ;    ;  ;      
  ;   ;    ;         ;   ;        ;   ;  ;   ;     ;    ;      ;   ;   ;   ;  ;;   ;     
  ;    ;;   ;;;;  ;;;     ;;       ;;;    ;;;      ;     ;;;;  ;    ;;;;;   ;; ;    ;;;; 
  ;                                                                            ;         
  ;                                                                       ;    ;         
  ;                                                                        ;;;;          
  
  
  (define test-coverage-enabled (make-parameter #f))
  
  (define current-test-coverage-info (make-thread-cell #f))
  
  (define (initialize-test-coverage-point expr)
    (unless (hash? (thread-cell-ref current-test-coverage-info))
      (let ([rep (drracket:rep:current-rep)])
        (when rep
          (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))])
            (when (eq? ut (current-thread))
              (let ([ht (make-hasheq)])
                (thread-cell-set! current-test-coverage-info ht)
                (send rep set-test-coverage-info ht)))))))
    (let ([ht (thread-cell-ref current-test-coverage-info)])
      (when (hash? ht)
        ;; if rep isn't around, we don't do test coverage...
        ;; this can happen when check syntax expands, for example
        (hash-set! ht expr #;(box #f) (mcons #f #f)))))
  
  (define (test-covered expr)
    (let ([ht (thread-cell-ref current-test-coverage-info)])
      (and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
           (let ([v (hash-ref ht expr #f)])
             ;; (and v (λ () (set-box! v #t)))
             (and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))))
  
  (define test-coverage-interactions-text<%>
    (interface ()
      set-test-coverage-info
      get-test-coverage-info))
  
  (define test-coverage-tab<%>
    (interface ()
      show-test-coverage-annotations ;; hash-table (union #f style) (union #f style) boolean -> void
      get-test-coverage-info-visible?
      ask-about-clearing-test-coverage?))
  
  (define test-coverage-interactions-text-mixin
    (mixin (drracket:rep:text<%> text:basic<%>) (test-coverage-interactions-text<%>)
      (inherit get-context)
      (field [test-coverage-info #f]
             [test-coverage-on-style #f]
             [test-coverage-off-style #f]
             [ask-about-reset? #f])
      (define/public set-test-coverage-info
        (λ (ht [on-style #f] [off-style #f] [ask? #t])
          (set! test-coverage-info ht)
          (set! test-coverage-on-style on-style)
          (set! test-coverage-off-style off-style)
          (set! ask-about-reset? ask?)))
      (define/public (get-test-coverage-info) 
        test-coverage-info)
      
      (inherit get-top-level-window)
      (define/augment (after-many-evals)
        (when test-coverage-info
          (send (get-context) show-test-coverage-annotations
                test-coverage-info
                test-coverage-on-style
                test-coverage-off-style
                ask-about-reset?))
        (inner (void) after-many-evals))
      
      (super-new)))
  
  (define test-coverage-definitions-text-mixin
    (mixin ((class->interface text%) drracket:unit:definitions-text<%>) ()
      (inherit get-canvas get-tab)
      
      (define/private (clear-test-coverage?)
        (if (preferences:get 'drracket:test-coverage-ask-about-clearing?)
            (let ([msg-box-result
                   (message-box/custom
                    (string-constant drscheme)
                    (string-constant test-coverage-clear?)
                    (string-constant yes)
                    (string-constant no)
                    (string-constant test-coverage-clear-and-do-not-ask-again)
                    (send (get-canvas) get-top-level-window)
                    '(default=1)
                    2)])
              (case msg-box-result
                [(1) #t]
                [(2) #f]
                [(3)
                 (preferences:set 'drracket:test-coverage-ask-about-clearing? #f)
                 #t]))
            #t))
      
      (define/public (clear-test-coverage)
        (let ([tab (get-tab)])
          (when (send tab get-test-coverage-info-visible?)
            (send tab clear-test-coverage-display)
            (let ([it (send tab get-ints)])
              (when (is-a? it test-coverage-interactions-text<%>)
                (send it set-test-coverage-info #f))))))
      
      (define/private (can-clear-coverage?)
        (let ([tab (get-tab)])
          (or (not tab)
              (not (send tab get-test-coverage-info-visible?))
              (not (send tab ask-about-clearing-test-coverage?))
              (clear-test-coverage?))))
      
      (define/augment (can-insert? x y)
        (and (inner #t can-insert? x y)
             (can-clear-coverage?)))
      
      (define/augment (can-delete? x y)
        (and (inner #t can-delete? x y)
             (can-clear-coverage?)))
      
      (define/augment (after-insert x y)
        (inner (void) after-insert x y)
        (clear-test-coverage))
      
      (define/augment (after-delete x y)
        (inner (void) after-delete x y)
        (clear-test-coverage))
      
      (super-new)))
  
  (define test-coverage-on-style-name "plt:module-language:test-coverage-on")
  (define test-coverage-off-style-name "plt:module-language:test-coverage-off")
  
  (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color))
  (send erase-test-coverage-style-delta set-transparent-text-backing-on #t)
  
  (define test-coverage-tab-mixin
    (mixin (drracket:rep:context<%> drracket:unit:tab<%>) (test-coverage-tab<%>)
      
      (field [internal-clear-test-coverage-display #f])
      
      (define/public (clear-test-coverage-display)
        (when internal-clear-test-coverage-display
          (internal-clear-test-coverage-display)
          (set! internal-clear-test-coverage-display #f)))
      
      (field [ask-about-reset? #t])
      (define/public (ask-about-clearing-test-coverage?) ask-about-reset?)
      
      (define/public (get-test-coverage-info-visible?)
        (not (not internal-clear-test-coverage-display)))
      
      (define/public (show-test-coverage-annotations ht on-style off-style ask?)
        (set! ask-about-reset? ask?)
        (let* ([edit-sequence-ht (make-hasheq)]
               [locked-ht (make-hasheq)]
               [already-frozen-ht (make-hasheq)]
               [actions-ht (make-hash)]
               
               ;; can-annotate : (listof (list boolean srcloc))
               ;; boolean is #t => code was run
               ;;            #f => code was not run
               ;; remove those that cannot be annotated
               [can-annotate
                (filter values
                        (hash-map ht
                          (λ (stx covered?)
                            (and (syntax? stx)
                                 (let ([src (syntax-source stx)]
                                       [pos (syntax-position stx)]
                                       [span (syntax-span stx)])
                                   (and pos
                                        span
                                        (send (get-defs) port-name-matches? src)
                                        (list (mcar covered?)
                                              (make-srcloc (get-defs) #f #f pos span))))))))]
               
               ;; filtered : (listof (list boolean srcloc))
               ;; remove redundant expressions
               [filtered
                (let (;; actions-ht : (list src number number) -> (list boolean syntax)
                      [actions-ht (make-hash)])
                  (for-each
                   (λ (pr)
                     (let* ([on? (list-ref pr 0)]
                            [key (list-ref pr 1)]
                            [old (hash-ref actions-ht key 'nothing)])
                       (cond
                         [(eq? old 'nothing) (hash-set! actions-ht key on?)]
                         [old ;; recorded as executed
                          (void)]
                         [(not old) ;; recorded as unexected
                          (when on?
                            (hash-set! actions-ht key #t))])))
                   can-annotate)
                  (hash-map actions-ht (λ (k v) (list v k))))])
          
          ;; if everything is covered *and* no coloring has been done, do no coloring.
          (unless (and (andmap car filtered)
                       (not (get-test-coverage-info-visible?)))
            
            (let (;; sorted : (listof (list boolean srcloc))
                  ;; sorting predicate:
                  ;;  x < y if
                  ;;    x's span is bigger than y's (ie, do larger expressions first)
                  ;;    unless x and y are the same source location.
                  ;;    in that case, color red first and then green
                  [sorted
                   (sort
                    filtered
                    (λ (x y)
                      (let* ([x-on (list-ref x 0)]
                             [y-on (list-ref y 0)]
                             [x-srcloc (list-ref x 1)]
                             [y-srcloc (list-ref y 1)]
                             [x-pos (srcloc-position x-srcloc)]
                             [y-pos (srcloc-position y-srcloc)]
                             [x-span (srcloc-span x-srcloc)]
                             [y-span (srcloc-span y-srcloc)])
                        (cond
                          [(and (= x-pos y-pos)
                                (= x-span x-span))
                           (or y-on
                               (not x-on))]
                          [else (>= x-span y-span)]))))])
              
              ;; turn on edit-sequences in all editors to be touched by new annotations
              ;; also fill in the edit-sequence-ht
              (for-each
               (λ (pr)
                 (let ([src (srcloc-source (list-ref pr 1))])
                   (hash-ref 
                    edit-sequence-ht
                    src
                    (λ ()
                      (hash-set! edit-sequence-ht src #f)
                      (send src begin-edit-sequence #f)
                      (when (send src is-locked?)
                        (hash-set! locked-ht src #t)
                        (send src lock #f))))))
               sorted)
              
              ;; clear out old annotations (and thaw colorers)
              (when internal-clear-test-coverage-display
                (internal-clear-test-coverage-display)
                (set! internal-clear-test-coverage-display #f))
              
              ;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw)
              (hash-for-each
               edit-sequence-ht
               (λ (src _)
                 (if (send src is-frozen?)
                     (hash-set! already-frozen-ht src #t)
                     (send src freeze-colorer))))
              
              ;; set new annotations
              (for-each
               (λ (pr)
                 (let ([on? (list-ref pr 0)]
                       [srcloc (list-ref pr 1)])
                   (let* ([src (srcloc-source srcloc)]
                          [pos (srcloc-position srcloc)]
                          [span (srcloc-span srcloc)])
                     (send src change-style
                           (if on?
                               (or on-style 
                                   (send (editor:get-standard-style-list)
                                         find-named-style 
                                         test-coverage-on-style-name))
                               (or off-style 
                                   (send (editor:get-standard-style-list)
                                         find-named-style 
                                         test-coverage-off-style-name)))
                           (- pos 1)
                           (+ (- pos 1) span)
                           #f))))
               sorted)
              
              ;; relock editors
              (hash-for-each 
               locked-ht
               (λ (txt _) (send txt lock #t)))
              
              ;; end edit sequences
              (hash-for-each 
               edit-sequence-ht
               (λ (txt _) (send txt end-edit-sequence)))
              
              ;; save thunk to reset these new annotations
              (set! internal-clear-test-coverage-display
                    (λ ()
                      (hash-for-each
                       edit-sequence-ht
                       (λ (txt _) 
                         (send txt begin-edit-sequence #f)))
                      (hash-for-each
                       edit-sequence-ht
                       (λ (txt _) 
                         (let ([locked? (send txt is-locked?)])
                           (when locked? (send txt lock #f))
                           (send txt change-style 
                                 erase-test-coverage-style-delta
                                 0
                                 (send txt last-position)
                                 #f)
                           (when locked? (send txt lock #t)))))
                      (hash-for-each
                       edit-sequence-ht
                       (λ (txt _) 
                         (unless (hash-ref already-frozen-ht txt #f)
                           (let ([locked? (send txt is-locked?)])
                             (when locked? (send txt lock #f))
                             (send txt thaw-colorer)
                             (when locked? (send txt lock #t))))
                         (send txt end-edit-sequence)))))))))
      
      (inherit get-defs)
      (define/augment (clear-annotations)
        (inner (void) clear-annotations)
        (send (get-defs) clear-test-coverage))
      
      (super-new)))
  
  
  
  
  
  ;                                                                 
  ;                                                                 
  ;                           ;;;        ;;;                        
  ;                          ;      ;      ;      ;                 
  ;                          ;             ;                        
  ;   ; ;;   ; ;;;   ;;;   ;;;;;; ;;;      ;    ;;;    ; ;;    ;; ; 
  ;   ;;  ;  ;;  ;  ;   ;    ;      ;      ;      ;    ;;  ;  ;  ;; 
  ;   ;   ;  ;      ;   ;    ;      ;      ;      ;    ;   ;  ;   ; 
  ;   ;   ;  ;      ;   ;    ;      ;      ;      ;    ;   ;  ;   ; 
  ;   ;   ;  ;      ;   ;    ;      ;      ;      ;    ;   ;  ;   ; 
  ;   ;;  ;  ;      ;   ;    ;      ;      ;      ;    ;   ;  ;  ;; 
  ;   ; ;;   ;       ;;;     ;      ;      ;      ;    ;   ;   ;; ; 
  ;   ;                                                           ; 
  ;   ;                                                        ;;;  
  ;                                                                 
  
  
  (define profile-key (gensym))
  
  ;; prof-info =
  ;; (make-prof-info
  ;;    boolean ;; protect against nested calls
  ;;    number[number of calls]
  ;;    number[time spent in all calls]
  ;;   (union #f symbol) 
  ;;   expression)
  (define-struct prof-info (nest num time name expr) #:mutable)
  
  ;; copy-prof-info : prof-info -> prof-info
  (define (copy-prof-info prof-info)
    (make-prof-info (prof-info-nest prof-info)
                    (prof-info-num prof-info)
                    (prof-info-time prof-info)
                    (prof-info-name prof-info)
                    (prof-info-expr prof-info)))
  
  ;; any-info? : prof-info -> boolean
  (define (any-info? prof-info)
    (or (not (zero? (prof-info-num prof-info)))
        (not (zero? (prof-info-time prof-info)))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; profiling runtime support
  
  ;; parameter
  ;; imported into errortrace
  (define profiling-enabled (make-parameter #f))
  
  ;; holds a hash-table for the profiling information
  (define current-profile-info (make-thread-cell #f))
  
  
  ;; initialize-profile-point : sym syntax syntax -> void
  ;; called during compilation to register this point as
  ;; a profile point. 
  ;; =User=
  ;; imported into errortrace
  (define (initialize-profile-point key name expr)
    (unless (thread-cell-ref current-profile-info)
      (let ([rep (drracket:rep:current-rep)])
        (when rep
          (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))])
            (when (eq? ut (current-thread))
              (let ([ht (make-hasheq)])
                (thread-cell-set! current-profile-info ht)
                (send (send rep get-context) add-profile-info ht)))))))
    (let ([profile-info (thread-cell-ref current-profile-info)])
      (when profile-info
        (hash-set! profile-info
                   key 
                   (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr))))
    (void))
  
  ;; register-profile-start : sym -> (union #f number)
  ;; =User=
  ;; imported into errortrace
  (define (register-profile-start key)
    (let ([ht (thread-cell-ref current-profile-info)])
      (when ht
        (let ([info (hash-ref ht key)])
          (set-prof-info-num! info (+ (prof-info-num info) 1))
          (if (prof-info-nest info)
              #f
              (begin
                (set-prof-info-nest! info #t)
                (current-process-milliseconds)))))))
  
  ;; register-profile-done : sym (union #f number) -> void
  ;; =User=
  ;; imported into errortrace
  (define (register-profile-done key start)
    (when start
      (let ([ht (thread-cell-ref current-profile-info)])
        (when ht
          (let ([info (hash-ref ht key)])
            (set-prof-info-nest! info #f)
            (set-prof-info-time! info
                                 (+ (- (current-process-milliseconds) start)
                                    (prof-info-time info)))))))
    (void))
  
  (define (get-color-value/pref val max-val drracket:profile:low-color drracket:profile:high-color drracket:profile:scale)
    (let* ([adjust
            (case drracket:profile:scale
              [(sqrt) sqrt]
              [(square) (λ (x) (* x x))]
              [(linear) (λ (x) x)])]
           [factor (adjust (if (zero? max-val) 0 (/ val max-val)))]
           [get-rgb-value
            (λ (sel)
              (let ([small (sel drracket:profile:low-color)]
                    [big (sel drracket:profile:high-color)])
                (inexact->exact (floor (+ (* factor (- big small)) small)))))])
      (make-object color% 
        (get-rgb-value (λ (x) (send x red)))
        (get-rgb-value (λ (x) (send x green)))
        (get-rgb-value (λ (x) (send x blue))))))
  
  ;; get-color-value : number number -> (is-a?/c color%)
  ;; returns the profiling color
  ;; for `val' if `max-val' is the largest
  ;; of any profiling amount.
  (define (get-color-value val max-val)
    (get-color-value/pref val 
                          max-val
                          (preferences:get 'drracket:profile:low-color)
                          (preferences:get 'drracket:profile:high-color)
                          (preferences:get 'drracket:profile:scale)))
  
  ;; extract-maximum : (listof prof-info) -> number
  ;; gets the maximum value of the currently preferred profiling info.
  (define (extract-maximum infos)
    (let ([max-value 0]
          [sel (if (eq? (preferences:get 'drracket:profile-how-to-count) 'time)
                   prof-info-time
                   prof-info-num)])
      (for-each
       (λ (val)
         (set! max-value (max max-value (sel val))))
       infos)
      max-value))
  
  ;; profile-definitions-mixin : mixin
  (define profile-definitions-text-mixin
    (mixin ((class->interface text%) drracket:unit:definitions-text<%>) ()
      (inherit get-canvas get-tab)
      
      (define/augment (can-insert? x y)
        (and (inner #t can-insert? x y)
             (can-reset-profile?)))
      
      (define/augment (can-delete? x y)
        (and (inner #t can-delete? x y)
             (can-reset-profile?)))
      
      (define/augment (on-insert x y)
        (inner (void) on-insert x y)
        (do-reset-profile))
      
      (define/augment (on-delete x y)
        (inner (void) on-delete x y)
        (do-reset-profile))
      
      (define/private (can-reset-profile?)
        (let ([canvas (get-canvas)])
          (or (not canvas)
              (let ([frame (send canvas get-top-level-window)])
                (or (not (send frame get-profile-info-visible?))
                    (eq? (message-box (string-constant drscheme)
                                      (string-constant profiling-clear?)
                                      frame
                                      '(yes-no))
                         'yes))))))
      
      (define/private (do-reset-profile)
        (send (get-tab) reset-profile))
      
      (super-new)))
  
  (define profile-interactions-tab<%>
    (interface ()
      add-profile-info))
  
  (define-local-member-name 
    
    ;; tab methods
    reset-profile  ;; erases profile display & information
    hide-profile  ;; hides profiling info, but it is still here to be shown again
    show-profile  ;; shows the profile info, if there is any to show
    refresh-profile ;; shows current info in profile window
    get-profile-info-text
    can-show-profile?
    get-sort-mode ;; indicates if the results are currently shown sorted by time, or not
    set-sort-mode ;; updates the sort mode flag (only called by the gui control callback)
    
    ;; frame methods
    hide-profile-gui
    show-profile-gui
    
    ;; frame and tab methods
    get-profile-info-visible?
    ; on frame, indicates if the gui stuff shows up currently
    ; on tab, indicates if the user has asked for the gui to show up.
    )
  
  (define profile-tab-mixin
    (mixin (drracket:unit:tab<%>) (profile-interactions-tab<%>)
      (define profile-info-visible? #f)
      (define/public (get-profile-info-visible?) profile-info-visible?)
      
      (define sort-mode (preferences:get 'drracket:profile-how-to-count))
      (define/public (get-sort-mode) sort-mode)
      (define/public (set-sort-mode mode) (set! sort-mode mode))
      
      (inherit get-frame is-current-tab? get-defs)
      ;; profile-info : (listof hashtable[symbol -o> prof-info])
      (define profile-info '())
      (define/public (add-profile-info ht) (set! profile-info (cons ht profile-info)))
      
      (define/public (show-profile)
        (unless profile-info-visible?
          (set! profile-info-visible? #t)
          (send (get-frame) show-profile-gui)))
      
      (define/public (hide-profile)
        (when profile-info-visible?
          (set! profile-info-visible? #f)
          (send profile-info-text clear-profile-display)
          (when (is-current-tab?)
            (send (get-frame) hide-profile-gui))))
      
      (define/public (reset-profile)
        (hide-profile)
        (set! profile-info '()))
      
      (define/public (refresh-profile) 
        (send profile-info-text refresh-profile profile-info (get-defs)))
      
      ;; can-show-profile? : -> boolean
      ;; indicates if there is any profiling information to be shown.
      (define/public (can-show-profile?)
        (let/ec esc-k
          (for-each
           (λ (ht)
             (hash-for-each
              ht
              (λ (key v)
                (when (any-info? v)
                  (esc-k #t)))))
           profile-info)
          #f))
      
      (define profile-info-text (new profile-text% (tab this)))
      (define/public (get-profile-info-text) profile-info-text)
      
      (define/augment (clear-annotations)
        (inner (void) clear-annotations)
        (reset-profile))
      
      (super-new)))
  
  ;; profile-unit-frame-mixin : mixin
  ;; adds profiling to the unit frame
  (define profile-unit-frame-mixin
    (mixin (drracket:unit:frame<%> drracket:frame:<%>) ()
      
      (inherit get-interactions-text get-current-tab)
      
      ;; update-shown : -> void
      ;; updates the state of the profile item's show menu
      (define/override (update-shown)
        (super update-shown)
        (send show-profile-menu-item set-label
              (if profile-info-visible?
                  (string-constant profiling-hide-profile)
                  (string-constant profiling-show-profile))))
      
      ;; add-show-menu-items : menu -> void
      ;; adds the show profile menu item
      (define/override (add-show-menu-items show-menu)
        (super add-show-menu-items show-menu)
        (set! show-profile-menu-item 
              (instantiate menu:can-restore-menu-item% ()
                (label (string-constant profiling-hide-profile))
                (parent show-menu)
                (callback
                 (λ (x y)
                   (show-profile-menu-callback))))))
      
      (define show-profile-menu-item #f)
      (define profile-gui-constructed? #f)
      
      ;; get-profile-info-visible? : -> boolean
      ;; returns #t when the profiling information is visible in the frame.
      (define/public (get-profile-info-visible?) profile-info-visible?)
      
      (field [profile-info-outer-panel #f])
      (define/override (make-root-area-container % parent)
        (set! profile-info-outer-panel
              (super make-root-area-container
                     vertical-panel%
                     parent))
        (make-object % profile-info-outer-panel))
      
      (define/private (show-profile-menu-callback)
        (cond
          [profile-info-visible?
           (send (get-current-tab) hide-profile)]
          [(send (get-current-tab) can-show-profile?)
           (send (get-current-tab) show-profile)
           (send (get-current-tab) refresh-profile)]
          [else
           (message-box (string-constant drscheme)
                        (string-constant profiling-no-information-available))]))
      
      (define/public (hide-profile-gui)
        (when profile-gui-constructed?
          (when profile-info-visible?
            (send profile-info-outer-panel change-children
                  (λ (l)
                    (remq profile-info-panel l)))
            (set! profile-info-visible? #f)
            (update-shown))))
      
      (define/public (show-profile-gui)
        (unless profile-info-visible?
          (construct-profile-gui)
          (send profile-info-outer-panel change-children
                (λ (l)
                  (append (remq profile-info-panel l)
                          (list profile-info-panel))))
          (set! profile-info-visible? #t)
          (send profile-info-editor-canvas set-editor (send (get-current-tab) get-profile-info-text))
          (send (get-current-tab) refresh-profile)
          (update-shown)))
      
      (field (profile-info-visible? #f))
      
      (define/augment (on-tab-change from-tab to-tab)
        (inner (void) on-tab-change from-tab to-tab)
        (cond
          [(and (not profile-info-visible?)
                (send to-tab get-profile-info-visible?))
           (show-profile-gui)]
          [(and profile-info-visible?
                (not (send to-tab get-profile-info-visible?)))
           (hide-profile-gui)])
        (when profile-choice
          (send profile-choice set-selection
                (profile-mode->selection
                 (send to-tab get-sort-mode))))
        (when profile-info-editor-canvas
          (send profile-info-editor-canvas set-editor 
                (and (send to-tab can-show-profile?)
                     (send to-tab get-profile-info-text)))))
      
      (super-new)
      
      (define profile-info-panel #f)
      (define profile-info-editor-canvas #f)
      (define profile-choice #f)
      
      (inherit begin-container-sequence end-container-sequence)
      (define/private (construct-profile-gui)
        (unless profile-gui-constructed?
          (set! profile-gui-constructed? #t)
          (begin-container-sequence)
          (let ()
            (define _2
              (set! profile-info-panel (instantiate horizontal-panel% ()
                                         (parent profile-info-outer-panel)
                                         (stretchable-height #f))))
            (define profile-left-side (instantiate vertical-panel% (profile-info-panel)))
            (define _3
              (set! profile-info-editor-canvas (new canvas:basic% 
                                                    (parent profile-info-panel)
                                                    (editor (send (get-current-tab) get-profile-info-text)))))
            (define profile-message (instantiate message% ()
                                      (label (string-constant profiling))
                                      (parent profile-left-side)))
            (define _4
              (set! profile-choice (instantiate radio-box% ()
                                     (label #f)
                                     (parent profile-left-side)
                                     (callback
                                      (λ (x y)
                                        (let ([mode (profile-selection->mode (send profile-choice get-selection))])
                                          (preferences:set 'drracket:profile-how-to-count mode)
                                          (send (get-current-tab) set-sort-mode mode)
                                          (send (get-current-tab) refresh-profile))))
                                     (choices (list (string-constant profiling-time)
                                                    (string-constant profiling-number))))))
            (define _1
              (send profile-choice set-selection
                    (case (preferences:get 'drracket:profile-how-to-count)
                      [(time) 0]
                      [(count) 1])))
            (define update-profile-button
              (instantiate button% ()
                (label (string-constant profiling-update))
                (parent profile-left-side)
                (callback
                 (λ (x y)
                   (send (get-current-tab) refresh-profile)))))
            (define hide-profile-button 
              (instantiate button% ()
                (label (string-constant profiling-hide-profile))
                (parent profile-left-side)
                (callback
                 (λ (x y)
                   (send (get-current-tab) hide-profile)))))
            (send profile-choice set-selection 
                  (profile-mode->selection (preferences:get 'drracket:profile-how-to-count)))
            
            (send profile-left-side stretchable-width #f)
            
            (let ([wid (max (send update-profile-button get-width)
                            (send hide-profile-button get-width)
                            (send profile-choice get-width)
                            (send profile-message get-width))])
              (send update-profile-button min-width wid)
              (send hide-profile-button min-width wid)
              (send profile-choice min-width wid))
            (send profile-left-side set-alignment 'left 'center)
            
            ;; hide profiling info initially, but reflow the container
            ;; so that the invisible children get the right size.
            (send this reflow-container)
            (send profile-info-outer-panel change-children
                  (λ (l)
                    (remq profile-info-panel l))))
          (end-container-sequence)))))
  
  (define (profile-selection->mode sel)
    (case sel
      [(0) 'time]
      [(1) 'count]))
  
  (define (profile-mode->selection mode)
    (case mode
      [(time) 0]
      [(count) 1]))
  
  ;; profile-text% : extends text:basic%
  ;; this class keeps track of a single thread's
  ;; profiling information. these methods are not
  ;; to be called directly, but only by the frame class, since
  ;; they do not completely implement the abstraction for the
  ;; GUI. They only manage the profiling information reported
  ;; in the bottom window
  (define profile-text% 
    (class text:basic%
      (init-field tab)
      
      ;; clear-profile-display : -> void
      ;; clears out the GUI showing the profile results
      (define/public (clear-profile-display)
        (begin-edit-sequence)
        (let ([locked? (is-locked?)])
          (lock #f)
          (clear-old-results)
          (erase)
          (lock locked?)
          (end-edit-sequence)))
      
      (inherit lock is-locked?
               get-canvas hide-caret get-snip-location
               begin-edit-sequence end-edit-sequence 
               erase insert)
      
      ;; clear-old-results : -> void
      ;; removes the profile highlighting
      (field [clear-old-results void])
      
      ;; refresh-profile : (listof hashtable[...]) text% -> void
      ;; does the work to erase any existing profile info
      ;; and make new profiling info.
      (define/public (refresh-profile profile-info definitions-text)
        (begin-edit-sequence)
        (lock #f)
        (erase)
        (clear-old-results)
        (let* (;; must copy them here in case the program is still running
               ;; and thus updating them.
               [infos '()]
               [_ (let loop ([profile-info profile-info])
                    (cond
                      [(null? profile-info) (void)]
                      [else 
                       (let ([ht (car profile-info)])
                         (hash-for-each
                          ht
                          (λ (key val)
                            (when (any-info? val)
                              (set! infos (cons (copy-prof-info val) infos))))))
                       (loop (cdr profile-info))]))]
               
               ;; each editor that gets some highlighting is put
               ;; into this table and an edit sequence is begun for it.
               ;; after all ranges are updated, the edit sequences are all closed.
               [in-edit-sequence (make-hasheq)]
               [clear-highlight void]
               [max-value (extract-maximum infos)]
               [show-highlight
                (λ (info)
                  (let* ([expr (prof-info-expr info)]
                         [src (and (syntax-source expr)
                                   (send definitions-text port-name-matches? (syntax-source expr))
                                   definitions-text)]
                         [pos (syntax-position expr)]
                         [span (syntax-span expr)])
                    (when (and (is-a? src text:basic<%>)
                               (number? pos)
                               (number? span))
                      (unless (hash-ref in-edit-sequence src (λ () #f))
                        (hash-set! in-edit-sequence src #t)
                        (send src begin-edit-sequence))
                      (let* ([color (get-color-value 
                                     (if (eq? (preferences:get 'drracket:profile-how-to-count) 'time)
                                         (prof-info-time info)
                                         (prof-info-num info))
                                     max-value)]
                             [clr (send src highlight-range (- pos 1) (+ pos span -1) color)])
                        (let ([old-thnk clear-highlight])
                          (set! clear-highlight
                                (λ ()
                                  (clr)
                                  (old-thnk))))))))]
               [smaller-range?
                (λ (x y)
                  (let ([x-span (syntax-span (prof-info-expr x))]
                        [y-span (syntax-span (prof-info-expr y))])
                    (if (and x-span y-span)
                        (< x-span y-span)
                        #f)))]
               
               [show-line
                (λ (info newline? highlight-line?)
                  (let* ([expr (prof-info-expr info)]
                         [expr-src (syntax-source expr)]
                         [count (prof-info-num info)]
                         [time (prof-info-time info)]
                         [name (prof-info-name info)])
                    (when newline? (send src-loc-editor insert "\n"))
                    (when highlight-line? (small-blank-line src-loc-editor))
                    (let ([before (send src-loc-editor last-position)])
                      (insert-profile-src-loc src-loc-editor expr name)
                      (let ([after (send src-loc-editor last-position)])
                        (cond
                          [(string? expr-src)
                           (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
                           (let ([after (send src-loc-editor last-position)])
                             (send src-loc-editor set-clickback 
                                   before after 
                                   (λ (text start end)
                                     (open-file-and-goto-position expr-src (syntax-position expr)))))]
                          [(is-a? expr-src editor:basic<%>)
                           (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
                           (send src-loc-editor set-clickback
                                 before after
                                 (λ (text start end)
                                   (let ([window (send expr-src get-top-level-window)]
                                         [pos (syntax-position expr)])
                                     (when window (send window show #t))
                                     (when pos (send expr-src set-position (- pos 1)))
                                     (send expr-src set-caret-owner #f 'global))))]
                          [else (void)])))
                    
                    (when newline? (send time-editor insert "\n"))
                    (when highlight-line? (small-blank-line time-editor))
                    (send time-editor insert (format "~a" time))
                    (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right)
                    
                    (when newline? (send count-editor insert "\n")) 
                    (when highlight-line? (small-blank-line count-editor))
                    (send count-editor insert (format "~a" count))
                    (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))]
               
               [bigger-value?
                (λ (x y)
                  (let ([sel (if (eq? 'count (preferences:get 'drracket:profile-how-to-count))
                                 prof-info-num
                                 prof-info-time)])
                    (> (sel x) (sel y))))]
               
               [cleanup-editor
                (λ (ed)
                  (let* ([ed-admin (send ed get-admin)]
                         [snip (send ed-admin get-snip)]
                         [bl (box 0)]
                         [br (box 0)])
                    (get-snip-location snip bl #f #f)
                    (get-snip-location snip br #f #t)
                    (let ([w (+ (- (unbox br) (unbox bl)) 4)])
                      (send ed set-max-width w)
                      (send ed set-min-width w)))
                  (send ed hide-caret #t)
                  (send ed lock #t))]
               
               [top-infos (top 100 (sort infos bigger-value?))])
          (for-each show-highlight top-infos)
          (initialize-editors)
          (let loop ([infos top-infos]
                     [newline? #f]
                     [highlight-counter 0])
            (cond
              [(null? infos) (void)]
              [else 
               (show-line (car infos) newline? (and newline? (zero? highlight-counter)))
               (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))]))
          (cleanup-editor count-editor)
          (cleanup-editor time-editor)
          (cleanup-editor src-loc-editor)
          
          (hash-for-each
           in-edit-sequence
           (λ (key val)
             (send key end-edit-sequence)))
          (set! clear-old-results 
                (λ ()
                  (hash-for-each
                   in-edit-sequence
                   (λ (key val) (send key begin-edit-sequence)))
                  (clear-highlight)
                  (hash-for-each
                   in-edit-sequence
                   (λ (key val) (send key end-edit-sequence)))
                  (set! clear-old-results void))))
        (lock #t)
        (end-edit-sequence)
        (let ([canvas (get-canvas)])
          (when canvas
            (send canvas scroll-to 0 0 1 1 #t 'start))))
      
      
      ;; top : number (listof X) -> (listof X)
      ;; extracts the first `n' elements from a list.
      (define/private (top n lst)
        (let loop ([n n]
                   [lst lst])
          (cond
            [(null? lst) null]
            [(= 0 n) null]
            [else (cons (car lst) (loop (- n 1) (cdr lst)))])))
      
      (field (src-loc-editor #f)
             (time-editor #f)
             (count-editor #f))
      (define/private (clear-editors)
        (set! src-loc-editor #f)
        (set! time-editor #f)
        (set! count-editor #f))
      (define/private (initialize-editors)
        (set! src-loc-editor (instantiate text% ()))
        (set! time-editor (instantiate text% ()))
        (set! count-editor (instantiate text% ()))
        (send src-loc-editor set-styles-sticky #f)            
        (send time-editor set-styles-sticky #f)
        (send count-editor set-styles-sticky #f)
        (insert (instantiate editor-snip% (time-editor)))
        (insert (instantiate editor-snip% (count-editor)))
        (insert (instantiate editor-snip% (src-loc-editor)))
        (insert-title (string-constant profiling-col-function) src-loc-editor)
        (insert-title (string-constant profiling-col-time-in-msec) time-editor)
        (insert-title (string-constant profiling-col-calls) count-editor))
      
      (define/private (insert-title str txt)
        (send txt insert str)
        (send txt insert "\n")
        (send txt change-style bold-delta 0 (- (send txt last-position) 1))
        (send txt set-paragraph-alignment 0 'center))
      
      (super-new)
      (hide-caret #t)))
  
  ;; format-percentage : number[0 <= n <= 1] -> string
  ;; formats the number as a percentage string with trailing zeros,
  ;; to 3 decimal places.
  (define (format-percentage n)
    (let* ([number-of-places 3]
           [whole-part (floor (* n 100))]
           [decimal-part (- (* n 100) whole-part)]
           [truncated/moved-decimal-part (floor (* (expt 10 number-of-places) decimal-part))]
           [pad
            (λ (str)
              (if ((string-length str) . < . number-of-places)
                  (string-append (make-string (- number-of-places (string-length str)) #\0) 
                                 str)
                  str))])
      (string-append (format "~a" whole-part)
                     "."
                     (pad (format "~a" truncated/moved-decimal-part)))))
  
  (define (small-blank-line txt)
    (let ([before (send txt last-position)])
      (send txt insert "\n")
      (let ([after (send txt last-position)])
        (send txt change-style small-font-style before after))))
  
  (define small-font-style (make-object style-delta% 'change-size 6))
  
  ;; bold-delta : style-delta
  (define bold-delta (make-object style-delta% 'change-bold))
  
  ;; insert-profile-src-loc : syntax name -> string
  (define (insert-profile-src-loc editor stx name)
    (cond
      [name
       (let ([before (send editor last-position)])
         (send editor insert (format "~a" name)))]
      [else
       (let* ([src (syntax-source stx)]
              [filename 
               (cond
                 [(string? src) src]
                 [(is-a? src editor<%>) (get-filename-from-editor src)]
                 [else (string-constant profiling-unknown-src)])]
              [col (syntax-column stx)]
              [line (syntax-line stx)]
              [pos (syntax-position stx)]
              [span (syntax-span stx)]
              [src
               (cond
                 [(and col line)
                  (format "~a: ~a.~a" filename line col)]
                 [pos
                  (format "~a: ~a" filename pos)]
                 [else 
                  filename])])
         (send editor insert src))]))
  
  ;; open-file-and-goto-position : string (union #f number) -> void
  (define (open-file-and-goto-position filename pos)
    (let ([frame (handler:edit-file filename)])
      (when (and frame
                 pos
                 (is-a? frame drracket:unit:frame%))
        (let ([defs (send frame get-definitions-text)])
          (send defs set-position (- pos 1))))))
  
  ;; get-src-filename : tst -> (union #f string)
  (define (get-src-filename src)
    (cond
      [(string? src) src]
      [(is-a? src text%)
       (send src get-filename)]
      [else #f]))
  
  ;; get-src-loc : syntax -> string
  (define (get-src-loc expr)
    (cond
      [(and (number? (syntax-line expr))
            (number? (syntax-column expr))
            (number? (syntax-span expr)))
       (format " ~a.~a [~a]" 
               (syntax-line expr) 
               (syntax-column expr)
               (syntax-span expr))]
      [(and (number? (syntax-position expr))
            (number? (syntax-span expr)))
       (format " ~a-~a" 
               (syntax-position expr)
               (syntax-span expr))]
      [else ""]))
  
  (define (add-prefs-panel)
    (preferences:add-panel
     (string-constant profiling)
     (λ (s-parent)
       (letrec ([parent (make-object vertical-panel% s-parent)]
                [msg (make-object message% 
                       (string-constant profiling-color-config) 
                       parent)]
                [hp (make-object horizontal-pane% parent)]
                [low (make-object button% (string-constant profiling-low-color) hp 
                       (λ (x y) (color-callback #t)))]
                [color-bar (make-object color-bar% hp)]
                [high (make-object button% (string-constant profiling-high-color) hp
                        (λ (x y) (color-callback #f)))]
                
                [scale (instantiate radio-box% ()
                         (label (string-constant profiling-scale))
                         (parent parent)
                         (callback (λ (x y) (scale-callback)))
                         (choices
                          (list (string-constant profiling-sqrt)
                                (string-constant profiling-linear)
                                (string-constant profiling-square))))]
                
                [color-callback
                 (λ (low?)
                   (let ([color (get-color-from-user 
                                 (if low?
                                     (string-constant profiling-choose-low-color)
                                     (string-constant profiling-choose-high-color))
                                 #f
                                 (preferences:get
                                  (if low?
                                      'drracket:profile:low-color
                                      'drracket:profile:high-color)))])
                     (when color
                       (preferences:set 
                        (if low? 'drracket:profile:low-color 'drracket:profile:high-color)
                        color))))]
                [scale-callback
                 (λ ()
                   (preferences:set 
                    'drracket:profile:scale
                    (case (send scale get-selection)
                      [(0) 'sqrt]
                      [(1) 'linear]
                      [(2) 'square])))])
         (preferences:add-callback
          'drracket:profile:scale
          (λ (p v)
            (send scale set-selection
                  (case v
                    [(sqrt) 0]
                    [(linear) 1]
                    [(square) 2]))))
         (send parent set-alignment 'left 'center)
         (send hp stretchable-height #f)
         parent))))
  
  (define color-bar%
    (class canvas%
      (inherit get-client-size get-dc)
      (field [pen (make-object pen% "black" 1 'solid)]
             [in-on-paint? #f])
      (define/override (on-paint)
        (set! in-on-paint? #t)
        (let* ([dc (get-dc)]
               [dummy-pen (send dc get-pen)]
               [drracket:profile:low-color (preferences:get 'drracket:profile:low-color)]
               [drracket:profile:high-color (preferences:get 'drracket:profile:high-color)]
               [drracket:profile:scale (preferences:get 'drracket:profile:scale)])
          (let-values ([(w h) (get-client-size)])
            (let loop ([n 0])
              (when (n . <= . w)
                (send pen set-color 
                      (get-color-value/pref n w drracket:profile:low-color drracket:profile:high-color drracket:profile:scale))
                (send dc set-pen pen)
                (send dc draw-line n 0 n h)
                (send dc set-pen dummy-pen)
                (loop (+ n 1))))
            (let-values ([(tw th ta td) (send dc get-text-extent 
                                              (string-constant profiling-example-text))])
              (send dc draw-text
                    (string-constant profiling-example-text)
                    (floor (- (/ w 2) (/ tw 2)))
                    (floor (- (/ h 2) (/ th 2)))))))
        (set! in-on-paint? #f))
      
      ;; queue callbacks here so that the preferences
      ;; values are actually set by the time on-paint
      ;; is called.
      (preferences:add-callback
       'drracket:profile:scale
       (λ (p v)
         (unless in-on-paint?
           (queue-callback
            (λ ()
              (on-paint))))))
      (preferences:add-callback
       'drracket:profile:low-color
       (λ (p v)
         (unless in-on-paint?
           (queue-callback
            (λ ()
              (on-paint))))))
      (preferences:add-callback
       'drracket:profile:high-color
       (λ (p v)
         (unless in-on-paint?
           (queue-callback
            (λ ()
              (on-paint))))))
      
      (super-instantiate ())))


  (define-values/invoke-unit/infer stacktrace@))
