#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)) (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^) (define (printf . args) (apply fprintf orig args)) ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ; ; ; ; ;;; ; ;; 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 "" (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 '()]))) (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 key 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 key (mcons #f expr))))) (define (test-covered key) (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 key #f)]) (and v (λ () (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-covered-style-delta (make-object style-delta%)) (define test-not-covered-style-delta (make-object style-delta%)) ;; test colors chosen to try to be color-blindness friendly (send test-covered-style-delta set-delta-foreground "forest green") (send test-not-covered-style-delta set-delta-foreground "maroon") (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)] [on/syntaxes (hash-map ht (λ (_ pr) pr))] ;; 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 (map (λ (pr) (let ([stx (mcdr pr)]) (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 pr) (make-srcloc (get-defs) #f #f pos span))))))) on/syntaxes))] ;; 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 test-covered-style-delta) (or off-style test-not-covered-style-delta)) (- 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@))