Rackety
This commit is contained in:
Robby Findler
parent
8f0c0f5405
commit
c7dd72ab4b
|
|
@ -315,7 +315,8 @@ profile todo:
|
|||
(oe annotated))])))))])
|
||||
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
|
||||
(define (make-debug-error-display-handler orig-error-display-handler)
|
||||
(define (debug-error-display-handler msg exn)
|
||||
|
|
@ -346,8 +347,10 @@ profile todo:
|
|||
(map cdr (filter cdr (cut-stack-at-checkpoint exn)))
|
||||
'())]
|
||||
[port-name-matches-cache (make-hasheq)]
|
||||
[stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack1)]
|
||||
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack2)]
|
||||
[stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
|
||||
stack1)]
|
||||
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
|
||||
stack2)]
|
||||
[src-locs (cond
|
||||
[(exn:srclocs? exn)
|
||||
((exn:srclocs-accessor exn) exn)]
|
||||
|
|
@ -358,7 +361,8 @@ profile todo:
|
|||
[(pair? stack2)
|
||||
(list (car stack2))]
|
||||
[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))])
|
||||
|
||||
(print-planet-icon-to-stderr exn)
|
||||
|
|
@ -506,7 +510,8 @@ profile todo:
|
|||
(install-pkg
|
||||
tlw
|
||||
(lambda (thunk)
|
||||
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
|
||||
(parameterize ([error-display-handler
|
||||
drracket:init:original-error-display-handler])
|
||||
(thunk)))
|
||||
#:package-to-offer pkg)))
|
||||
(eprintf " ")
|
||||
|
|
@ -526,7 +531,11 @@ profile todo:
|
|||
(when note%
|
||||
(let ([note (new note%)])
|
||||
(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))
|
||||
(display #\space (current-error-port)))))))
|
||||
|
||||
|
|
@ -810,7 +819,10 @@ profile todo:
|
|||
(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) (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))]
|
||||
[else
|
||||
(set! index n)]))
|
||||
|
|
@ -881,7 +893,8 @@ profile todo:
|
|||
[else
|
||||
(define di2 (car dis))
|
||||
(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)
|
||||
(values res-dis res-editions (cons (+ (car skip-counts) 1) (cdr skip-counts)))
|
||||
(values (cons di res-dis)
|
||||
|
|
@ -959,17 +972,18 @@ profile todo:
|
|||
;; ->
|
||||
;; void
|
||||
(define (insert-context editor-canvas text file start span defs ints)
|
||||
(let-values ([(from-text close-text)
|
||||
(define-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
|
||||
(define file
|
||||
(with-handlers ((exn:fail? (λ (x) #f)))
|
||||
(normal-case-path (normalize-path file))))
|
||||
(cond
|
||||
[(not file) (values #f void)]
|
||||
[(send (group:get-the-frame-group)
|
||||
locate-file
|
||||
file)
|
||||
|
|
@ -984,7 +998,8 @@ profile todo:
|
|||
(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)))
|
||||
(equal?
|
||||
(normalize-path (normal-case-path (send defs get-filename)))
|
||||
file))
|
||||
(values defs void)
|
||||
(loop (cdr tabs))))]))]
|
||||
|
|
@ -998,12 +1013,10 @@ profile todo:
|
|||
(λ () (send text on-close)))
|
||||
(values #f (λ () (void)))))]
|
||||
[else
|
||||
(values #f void)])
|
||||
(values #f void)))]
|
||||
(values #f void)])]
|
||||
[(is-a? file editor<%>)
|
||||
(values file void)]
|
||||
[else
|
||||
(values #f void)])])
|
||||
[else (values #f void)]))
|
||||
(when from-text
|
||||
(let* ([finish (+ start span -1)]
|
||||
[context-text (copy/highlight-text from-text start finish)])
|
||||
|
|
@ -1018,7 +1031,7 @@ profile todo:
|
|||
(send text insert #\newline)
|
||||
(when (preferences:get 'framework:white-on-black?)
|
||||
(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 stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white"))
|
||||
|
|
@ -1308,7 +1321,8 @@ profile todo:
|
|||
[span (syntax-span stx)])
|
||||
(and pos
|
||||
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?)
|
||||
(make-srcloc (get-defs) #f #f pos span))))))))]
|
||||
|
||||
|
|
@ -1563,7 +1577,10 @@ profile todo:
|
|||
(prof-info-time info)))))))
|
||||
(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
|
||||
(case drracket:profile:scale
|
||||
[(sqrt) sqrt]
|
||||
|
|
@ -1834,36 +1851,34 @@ profile todo:
|
|||
(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))))
|
||||
(stretchable-height #f)))
|
||||
(define profile-left-side (instantiate vertical-panel% (profile-info-panel)))
|
||||
(define _3
|
||||
(set! profile-info-editor-canvas (new canvas:basic%
|
||||
(set! profile-info-editor-canvas
|
||||
(new canvas:basic%
|
||||
(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% ()
|
||||
(label (string-constant profiling))
|
||||
(parent profile-left-side)))
|
||||
(define _4
|
||||
(set! profile-choice (instantiate radio-box% ()
|
||||
(set! profile-choice (new radio-box%
|
||||
(label #f)
|
||||
(parent profile-left-side)
|
||||
(callback
|
||||
(λ (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)
|
||||
(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)
|
||||
(string-constant profiling-number))))))
|
||||
(define _1
|
||||
(string-constant profiling-number)))))
|
||||
(send profile-choice set-selection
|
||||
(case (preferences:get 'drracket:profile-how-to-count)
|
||||
[(time) 0]
|
||||
[(count) 1])))
|
||||
[(count) 1]))
|
||||
(define update-profile-button
|
||||
(instantiate button% ()
|
||||
(label (string-constant profiling-update))
|
||||
|
|
@ -1897,7 +1912,7 @@ profile todo:
|
|||
(send this reflow-container)
|
||||
(send profile-info-outer-panel change-children
|
||||
(λ (l)
|
||||
(remq profile-info-panel l))))
|
||||
(remq profile-info-panel l)))
|
||||
(end-container-sequence)))))
|
||||
|
||||
(define (profile-selection->mode sel)
|
||||
|
|
@ -1949,10 +1964,8 @@ profile todo:
|
|||
(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])
|
||||
(define infos '())
|
||||
(let loop ([profile-info profile-info])
|
||||
(cond
|
||||
[(null? profile-info) (void)]
|
||||
[else
|
||||
|
|
@ -1962,26 +1975,26 @@ profile todo:
|
|||
(λ (key val)
|
||||
(when (any-info? val)
|
||||
(set! infos (cons (copy-prof-info val) infos))))))
|
||||
(loop (cdr profile-info))]))]
|
||||
(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)]
|
||||
(define in-edit-sequence (make-hasheq))
|
||||
(define clear-highlight void)
|
||||
(define max-value (extract-maximum infos))
|
||||
|
||||
[port-name-matches-cache (make-hasheq)]
|
||||
[show-highlight
|
||||
(λ (info)
|
||||
(let* ([expr (prof-info-expr info)]
|
||||
[src (and (syntax-source expr)
|
||||
(define port-name-matches-cache (make-hasheq))
|
||||
(define (show-highlight info)
|
||||
(define expr (prof-info-expr info))
|
||||
(define src
|
||||
(and (syntax-source expr)
|
||||
definitions-text
|
||||
(hash-ref! port-name-matches-cache
|
||||
(syntax-source expr)
|
||||
(λ () (send definitions-text port-name-matches? (syntax-source expr)))))]
|
||||
[pos (syntax-position expr)]
|
||||
[span (syntax-span expr)])
|
||||
(λ () (send definitions-text port-name-matches? (syntax-source expr))))))
|
||||
(define pos (syntax-position expr))
|
||||
(define span (syntax-span expr))
|
||||
(when (and (is-a? src text:basic<%>)
|
||||
(number? pos)
|
||||
(number? span))
|
||||
|
|
@ -1998,17 +2011,15 @@ profile todo:
|
|||
(set! clear-highlight
|
||||
(λ ()
|
||||
(clr)
|
||||
(old-thnk))))))))]
|
||||
[smaller-range?
|
||||
(λ (x y)
|
||||
(old-thnk)))))))
|
||||
(define (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)))]
|
||||
#f)))
|
||||
|
||||
[show-line
|
||||
(λ (info newline? highlight-line?)
|
||||
(define (show-line info newline? highlight-line?)
|
||||
(let* ([expr (prof-info-expr info)]
|
||||
[expr-src (syntax-source expr)]
|
||||
[count (prof-info-num info)]
|
||||
|
|
@ -2047,17 +2058,15 @@ profile todo:
|
|||
(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)))]
|
||||
(send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))
|
||||
|
||||
[bigger-value?
|
||||
(λ (x y)
|
||||
(define (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))))]
|
||||
(> (sel x) (sel y))))
|
||||
|
||||
[cleanup-editor
|
||||
(λ (ed)
|
||||
(define (cleanup-editor ed)
|
||||
(let* ([ed-admin (send ed get-admin)]
|
||||
[snip (send ed-admin get-snip)]
|
||||
[bl (box 0)]
|
||||
|
|
@ -2068,9 +2077,9 @@ profile todo:
|
|||
(send ed set-max-width w)
|
||||
(send ed set-min-width w)))
|
||||
(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)
|
||||
(initialize-editors)
|
||||
(let loop ([infos top-infos]
|
||||
|
|
@ -2098,7 +2107,7 @@ profile todo:
|
|||
(hash-for-each
|
||||
in-edit-sequence
|
||||
(λ (key val) (send key end-edit-sequence)))
|
||||
(set! clear-old-results void))))
|
||||
(set! clear-old-results void)))
|
||||
(lock #t)
|
||||
(end-edit-sequence)
|
||||
(let ([canvas (get-canvas)])
|
||||
|
|
@ -2311,7 +2320,10 @@ profile todo:
|
|||
(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))
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user