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

make the drr log follower show its results in a separate window

Browse Source 
original commit: a5961dcf366dafe5830bcd93c984b4601625204d
This commit is contained in:
Robby Findler 2012-11-27 22:53:19 -06:00
parent 7154fcca6b
commit f0e71cebf5
1 changed files with 71 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/tests/drracket/follow-log.rkt
View File

@ -34,10 +34,9 @@ log message was reported.
'debug 'framework/colorer 'debug 'framework/colorer
'debug 'timeline)) 'debug 'timeline))
(define top-n-events 50) (define top-n-events 30)
(define drop-gc? #f) (define drop-gc? #f)
(define start-right-away? #t) ;; only applies if the 'main' module is loaded (define start-right-away? #t) ;; only applies if the 'main' module is loaded
(define show-hist? #t)
(define script-drr? #t) (define script-drr? #t)
(define interesting-range-start 26) (define interesting-range-start 26)
(define interesting-range-end +inf.0) (define interesting-range-end +inf.0)
@ -105,6 +104,8 @@ log message was reported.
(λ (_1 _2) (λ (_1 _2)
(stop-and-dump))])) (stop-and-dump))]))
(define (stop-and-dump) (define (stop-and-dump)
(define sp (open-output-string))
(parameterize ([current-output-port sp])
(cond (cond
[following-log? [following-log?
(define resp (make-channel)) (define resp (make-channel))
@ -123,6 +124,20 @@ log message was reported.
(send sb enable #t) (send sb enable #t)
(send sb2 enable #t) (send sb2 enable #t)
(set! following-bt? #f)])) (set! following-bt? #f)]))
(show-string (get-output-string sp)))
(define (show-string str)
(define t (new text%))
(send t insert str)
(send t change-style (make-object style-delta% 'change-family 'modern)
0
(send t last-position))
(define f (new frame% [width 600] [height 800] [label "Log Follower Results"]))
(define ec (new editor-canvas% [parent f] [editor t]))
(define mb (new menu-bar% [parent f]))
(define edit-menu (new menu% [label "Edit"] [parent mb]))
(append-editor-operation-menu-items edit-menu)
(send f show #t))
(define following-log? #f) (define following-log? #f)
(define following-bt? #f) (define following-bt? #f)
@ -192,8 +207,7 @@ log message was reported.
(number? (gui-event-end i)))) (number? (gui-event-end i))))
evts)) evts))
(cond (define (show-hist)
[show-hist?
(define gc-starts+ends (define gc-starts+ends
(filter (filter
values values
@ -221,8 +235,9 @@ log message was reported.
(printf "\nwithout gc\n") (printf "\nwithout gc\n")
(print-gui-event-hist no-gc-events) (print-gui-event-hist no-gc-events)
(printf "\nboth with and without gc\n") (printf "\nboth with and without gc\n")
(print-gui-event-hist gui-events)] (print-gui-event-hist gui-events))
[else
(define (show-top-events)
(define interesting-gui-events (define interesting-gui-events
(let ([candidate-events (let ([candidate-events
(sort (filter (λ (x) (sort (filter (λ (x)
@ -262,7 +277,11 @@ log message was reported.
(if drop-gc? (if drop-gc?
(filter (λ (x) (not (has-a-gc-event? x))) (filter (λ (x) (not (has-a-gc-event? x)))
with-other-events) with-other-events)
with-other-events))])) with-other-events)))
(show-top-events)
(printf "\n\n============================================================\n\n\n")
(show-hist))
(struct gc-info (major? pre-amount pre-admin-amount code-amount (struct gc-info (major? pre-amount pre-admin-amount code-amount
post-amount post-admin-amount post-amount post-admin-amount
@ -376,3 +395,4 @@ log message was reported.
(queue-callback (queue-callback
(λ () (λ ()
(run-drracket-script)))))) (run-drracket-script))))))