suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rackety

Browse Source
This commit is contained in:
Robby Findler 2014-07-13 22:31:22 -05:00
parent 8f0c0f5405
commit c7dd72ab4b
1 changed files with 297 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
View File

@ -315,7 +315,8 @@ profile todo:
(oe annotated))])))))]) (oe annotated))])))))])
debug-tool-eval-handler)) debug-tool-eval-handler))
;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void ;; 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 ;; adds in the bug icon, if there are contexts to display
(define (make-debug-error-display-handler orig-error-display-handler) (define (make-debug-error-display-handler orig-error-display-handler)
(define (debug-error-display-handler msg exn) (define (debug-error-display-handler msg exn)
@ -346,8 +347,10 @@ profile todo:
(map cdr (filter cdr (cut-stack-at-checkpoint exn))) (map cdr (filter cdr (cut-stack-at-checkpoint exn)))
'())] '())]
[port-name-matches-cache (make-hasheq)] [port-name-matches-cache (make-hasheq)]
[stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack1)] [stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack2)] stack1)]
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
stack2)]
[src-locs (cond [src-locs (cond
[(exn:srclocs? exn) [(exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)] ((exn:srclocs-accessor exn) exn)]
@ -358,7 +361,8 @@ profile todo:
[(pair? stack2) [(pair? stack2)
(list (car stack2))] (list (car stack2))]
[else '()])] [else '()])]
[src-locs-edition (and (pair? src-locs) [src-locs-edition
(and (pair? src-locs)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn) (print-planet-icon-to-stderr exn)
@ -506,7 +510,8 @@ profile todo:
(install-pkg (install-pkg
tlw tlw
(lambda (thunk) (lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler]) (parameterize ([error-display-handler
drracket:init:original-error-display-handler])
(thunk))) (thunk)))
#:package-to-offer pkg))) #:package-to-offer pkg)))
(eprintf " ") (eprintf " ")
@ -526,7 +531,11 @@ profile todo:
(when note% (when note%
(let ([note (new note%)]) (let ([note (new note%)])
(send note set-stacks cms1 cms2) (send note set-stacks cms1 cms2)
(send note set-callback (λ (snp) (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints))) (send note set-callback
(λ (snp) (show-backtrace-window/edition-pairs/two msg
cms1 editions1
cms2 editions2
defs ints)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port))))))) (display #\space (current-error-port)))))))
@ -810,7 +819,10 @@ profile todo:
(cond (cond
[(and (< n (vector-length di-vec)) [(and (< n (vector-length di-vec))
(< n (+ index how-many-at-once))) (< n (+ index how-many-at-once)))
(show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) (vector-ref skip-counts n) defs ints) (show-frame ec text (vector-ref di-vec n)
(vector-ref editions-vec n)
(vector-ref skip-counts n)
defs ints)
(loop (+ n 1))] (loop (+ n 1))]
[else [else
(set! index n)])) (set! index n)]))
@ -881,7 +893,8 @@ profile todo:
[else [else
(define di2 (car dis)) (define di2 (car dis))
(define edition2 (car editions)) (define edition2 (car editions))
(define-values (res-dis res-editions skip-counts) (loop di2 edition2 (cdr dis) (cdr editions))) (define-values (res-dis res-editions skip-counts)
(loop di2 edition2 (cdr dis) (cdr editions)))
(if (equal? di di2) (if (equal? di di2)
(values res-dis res-editions (cons (+ (car skip-counts) 1) (cdr skip-counts))) (values res-dis res-editions (cons (+ (car skip-counts) 1) (cdr skip-counts)))
(values (cons di res-dis) (values (cons di res-dis)
@ -959,17 +972,18 @@ profile todo:
;; -> ;; ->
;; void ;; void
(define (insert-context editor-canvas text file start span defs ints) (define (insert-context editor-canvas text file start span defs ints)
(let-values ([(from-text close-text) (define-values (from-text close-text)
(cond (cond
[(and ints (send ints port-name-matches? file)) [(and ints (send ints port-name-matches? file))
(values ints void)] (values ints void)]
[(and defs (send defs port-name-matches? file)) [(and defs (send defs port-name-matches? file))
(values defs void)] (values defs void)]
[(path? file) [(path? file)
(let ([file (with-handlers ((exn:fail? (λ (x) #f))) (define file
(normal-case-path (normalize-path file)))]) (with-handlers ((exn:fail? (λ (x) #f)))
(if file (normal-case-path (normalize-path file))))
(cond (cond
[(not file) (values #f void)]
[(send (group:get-the-frame-group) [(send (group:get-the-frame-group)
locate-file locate-file
file) file)
@ -984,7 +998,8 @@ profile todo:
(let* ([tab (car tabs)] (let* ([tab (car tabs)]
[defs (send tab get-defs)]) [defs (send tab get-defs)])
(if (with-handlers ((exn:fail? (λ (x) #f))) (if (with-handlers ((exn:fail? (λ (x) #f)))
(equal? (normalize-path (normal-case-path (send defs get-filename))) (equal?
(normalize-path (normal-case-path (send defs get-filename)))
file)) file))
(values defs void) (values defs void)
(loop (cdr tabs))))]))] (loop (cdr tabs))))]))]
@ -998,12 +1013,10 @@ profile todo:
(λ () (send text on-close))) (λ () (send text on-close)))
(values #f (λ () (void)))))] (values #f (λ () (void)))))]
[else [else
(values #f void)]) (values #f void)])]
(values #f void)))]
[(is-a? file editor<%>) [(is-a? file editor<%>)
(values file void)] (values file void)]
[else [else (values #f void)]))
(values #f void)])])
(when from-text (when from-text
(let* ([finish (+ start span -1)] (let* ([finish (+ start span -1)]
[context-text (copy/highlight-text from-text start finish)]) [context-text (copy/highlight-text from-text start finish)])
@ -1018,7 +1031,7 @@ profile todo:
(send text insert #\newline) (send text insert #\newline)
(when (preferences:get 'framework:white-on-black?) (when (preferences:get 'framework:white-on-black?)
(send text change-style white-on-black-style p (+ p 1)))))) (send text change-style white-on-black-style p (+ p 1))))))
(close-text)))) (close-text)))
(define white-on-black-style (make-object style-delta%)) (define white-on-black-style (make-object style-delta%))
(define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white")) (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white"))
@ -1308,7 +1321,8 @@ profile todo:
[span (syntax-span stx)]) [span (syntax-span stx)])
(and pos (and pos
span span
(hash-ref! port-name-cache src (λ () (send (get-defs) port-name-matches? src))) (hash-ref! port-name-cache src
(λ () (send (get-defs) port-name-matches? src)))
(list (mcar covered?) (list (mcar covered?)
(make-srcloc (get-defs) #f #f pos span))))))))] (make-srcloc (get-defs) #f #f pos span))))))))]
@ -1563,7 +1577,10 @@ profile todo:
(prof-info-time info))))))) (prof-info-time info)))))))
(void)) (void))
(define (get-color-value/pref val max-val drracket:profile:low-color drracket:profile:high-color drracket:profile:scale) (define (get-color-value/pref val max-val
drracket:profile:low-color
drracket:profile:high-color
drracket:profile:scale)
(let* ([adjust (let* ([adjust
(case drracket:profile:scale (case drracket:profile:scale
[(sqrt) sqrt] [(sqrt) sqrt]
@ -1834,36 +1851,34 @@ profile todo:
(unless profile-gui-constructed? (unless profile-gui-constructed?
(set! profile-gui-constructed? #t) (set! profile-gui-constructed? #t)
(begin-container-sequence) (begin-container-sequence)
(let ()
(define _2
(set! profile-info-panel (instantiate horizontal-panel% () (set! profile-info-panel (instantiate horizontal-panel% ()
(parent profile-info-outer-panel) (parent profile-info-outer-panel)
(stretchable-height #f)))) (stretchable-height #f)))
(define profile-left-side (instantiate vertical-panel% (profile-info-panel))) (define profile-left-side (instantiate vertical-panel% (profile-info-panel)))
(define _3 (set! profile-info-editor-canvas
(set! profile-info-editor-canvas (new canvas:basic% (new canvas:basic%
(parent profile-info-panel) (parent profile-info-panel)
(editor (send (get-current-tab) get-profile-info-text))))) (editor (send (get-current-tab) get-profile-info-text))))
(define profile-message (instantiate message% () (define profile-message (instantiate message% ()
(label (string-constant profiling)) (label (string-constant profiling))
(parent profile-left-side))) (parent profile-left-side)))
(define _4 (set! profile-choice (new radio-box%
(set! profile-choice (instantiate radio-box% ()
(label #f) (label #f)
(parent profile-left-side) (parent profile-left-side)
(callback (callback
(λ (x y) (λ (x y)
(let ([mode (profile-selection->mode (send profile-choice get-selection))]) (define mode
(profile-selection->mode
(send profile-choice get-selection)))
(preferences:set 'drracket:profile-how-to-count mode) (preferences:set 'drracket:profile-how-to-count mode)
(send (get-current-tab) set-sort-mode mode) (send (get-current-tab) set-sort-mode mode)
(send (get-current-tab) refresh-profile)))) (send (get-current-tab) refresh-profile)))
(choices (list (string-constant profiling-time) (choices (list (string-constant profiling-time)
(string-constant profiling-number)))))) (string-constant profiling-number)))))
(define _1
(send profile-choice set-selection (send profile-choice set-selection
(case (preferences:get 'drracket:profile-how-to-count) (case (preferences:get 'drracket:profile-how-to-count)
[(time) 0] [(time) 0]
[(count) 1]))) [(count) 1]))
(define update-profile-button (define update-profile-button
(instantiate button% () (instantiate button% ()
(label (string-constant profiling-update)) (label (string-constant profiling-update))
@ -1897,7 +1912,7 @@ profile todo:
(send this reflow-container) (send this reflow-container)
(send profile-info-outer-panel change-children (send profile-info-outer-panel change-children
(λ (l) (λ (l)
(remq profile-info-panel l)))) (remq profile-info-panel l)))
(end-container-sequence))))) (end-container-sequence)))))
(define (profile-selection->mode sel) (define (profile-selection->mode sel)
@ -1949,10 +1964,8 @@ profile todo:
(lock #f) (lock #f)
(erase) (erase)
(clear-old-results) (clear-old-results)
(let* (;; must copy them here in case the program is still running (define infos '())
;; and thus updating them. (let loop ([profile-info profile-info])
[infos '()]
[_ (let loop ([profile-info profile-info])
(cond (cond
[(null? profile-info) (void)] [(null? profile-info) (void)]
[else [else
@ -1962,26 +1975,26 @@ profile todo:
(λ (key val) (λ (key val)
(when (any-info? val) (when (any-info? val)
(set! infos (cons (copy-prof-info val) infos)))))) (set! infos (cons (copy-prof-info val) infos))))))
(loop (cdr profile-info))]))] (loop (cdr profile-info))]))
;; each editor that gets some highlighting is put ;; each editor that gets some highlighting is put
;; into this table and an edit sequence is begun for it. ;; into this table and an edit sequence is begun for it.
;; after all ranges are updated, the edit sequences are all closed. ;; after all ranges are updated, the edit sequences are all closed.
[in-edit-sequence (make-hasheq)] (define in-edit-sequence (make-hasheq))
[clear-highlight void] (define clear-highlight void)
[max-value (extract-maximum infos)] (define max-value (extract-maximum infos))
[port-name-matches-cache (make-hasheq)] (define port-name-matches-cache (make-hasheq))
[show-highlight (define (show-highlight info)
(λ (info) (define expr (prof-info-expr info))
(let* ([expr (prof-info-expr info)] (define src
[src (and (syntax-source expr) (and (syntax-source expr)
definitions-text definitions-text
(hash-ref! port-name-matches-cache (hash-ref! port-name-matches-cache
(syntax-source expr) (syntax-source expr)
(λ () (send definitions-text port-name-matches? (syntax-source expr)))))] (λ () (send definitions-text port-name-matches? (syntax-source expr))))))
[pos (syntax-position expr)] (define pos (syntax-position expr))
[span (syntax-span expr)]) (define span (syntax-span expr))
(when (and (is-a? src text:basic<%>) (when (and (is-a? src text:basic<%>)
(number? pos) (number? pos)
(number? span)) (number? span))
@ -1998,17 +2011,15 @@ profile todo:
(set! clear-highlight (set! clear-highlight
(λ () (λ ()
(clr) (clr)
(old-thnk))))))))] (old-thnk)))))))
[smaller-range? (define (smaller-range? x y)
(λ (x y)
(let ([x-span (syntax-span (prof-info-expr x))] (let ([x-span (syntax-span (prof-info-expr x))]
[y-span (syntax-span (prof-info-expr y))]) [y-span (syntax-span (prof-info-expr y))])
(if (and x-span y-span) (if (and x-span y-span)
(< x-span y-span) (< x-span y-span)
#f)))] #f)))
[show-line (define (show-line info newline? highlight-line?)
(λ (info newline? highlight-line?)
(let* ([expr (prof-info-expr info)] (let* ([expr (prof-info-expr info)]
[expr-src (syntax-source expr)] [expr-src (syntax-source expr)]
[count (prof-info-num info)] [count (prof-info-num info)]
@ -2047,17 +2058,15 @@ profile todo:
(when newline? (send count-editor insert "\n")) (when newline? (send count-editor insert "\n"))
(when highlight-line? (small-blank-line count-editor)) (when highlight-line? (small-blank-line count-editor))
(send count-editor insert (format "~a" count)) (send count-editor insert (format "~a" count))
(send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))] (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))
[bigger-value? (define (bigger-value? x y)
(λ (x y)
(let ([sel (if (eq? 'count (preferences:get 'drracket:profile-how-to-count)) (let ([sel (if (eq? 'count (preferences:get 'drracket:profile-how-to-count))
prof-info-num prof-info-num
prof-info-time)]) prof-info-time)])
(> (sel x) (sel y))))] (> (sel x) (sel y))))
[cleanup-editor (define (cleanup-editor ed)
(λ (ed)
(let* ([ed-admin (send ed get-admin)] (let* ([ed-admin (send ed get-admin)]
[snip (send ed-admin get-snip)] [snip (send ed-admin get-snip)]
[bl (box 0)] [bl (box 0)]
@ -2068,9 +2077,9 @@ profile todo:
(send ed set-max-width w) (send ed set-max-width w)
(send ed set-min-width w))) (send ed set-min-width w)))
(send ed hide-caret #t) (send ed hide-caret #t)
(send ed lock #t))] (send ed lock #t))
[top-infos (top 100 (sort infos bigger-value?))]) (define top-infos (top 100 (sort infos bigger-value?)))
(for-each show-highlight top-infos) (for-each show-highlight top-infos)
(initialize-editors) (initialize-editors)
(let loop ([infos top-infos] (let loop ([infos top-infos]
@ -2098,7 +2107,7 @@ profile todo:
(hash-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (send key end-edit-sequence))) (λ (key val) (send key end-edit-sequence)))
(set! clear-old-results void)))) (set! clear-old-results void)))
(lock #t) (lock #t)
(end-edit-sequence) (end-edit-sequence)
(let ([canvas (get-canvas)]) (let ([canvas (get-canvas)])
@ -2311,7 +2320,10 @@ profile todo:
(let loop ([n 0]) (let loop ([n 0])
(when (n . <= . w) (when (n . <= . w)
(send pen set-color (send pen set-color
(get-color-value/pref n w drracket:profile:low-color drracket:profile:high-color drracket:profile:scale)) (get-color-value/pref n w
drracket:profile:low-color
drracket:profile:high-color
drracket:profile:scale))
(send dc set-pen pen) (send dc set-pen pen)
(send dc draw-line n 0 n h) (send dc draw-line n 0 n h)
(send dc set-pen dummy-pen) (send dc set-pen dummy-pen)