2125 lines
90 KiB
Racket
2125 lines
90 KiB
Racket
#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 (exn:fail:user? 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@))
|