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

adjust log following to make it work for the middle of a drracket

Browse Source 
editing session
This commit is contained in:
Robby Findler 2012-11-04 14:36:48 -06:00
parent e9e2557356
commit ef3eb3154a
1 changed files with 38 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/drracket/private/follow-log.rkt
View File

@ -18,6 +18,7 @@ log message was reported.
|# |#
(define lr (make-log-receiver (current-logger) (define lr (make-log-receiver (current-logger)
'debug 'racket/engine 'debug 'racket/engine
'debug 'GC 'debug 'GC
@ -27,11 +28,15 @@ log message was reported.
(define top-n-events 50) (define top-n-events 50)
(define drop-gc? #t) (define drop-gc? #t)
(define start-right-away? #f)
(define done-chan (make-channel)) (define done-chan (make-channel))
(define start-chan (make-channel))
(void (void
(thread (thread
(λ () (λ ()
(let loop ()
(sync start-chan)
(let loop ([events '()]) (let loop ([events '()])
(sync (sync
(handle-evt (handle-evt
@ -41,17 +46,28 @@ log message was reported.
(handle-evt (handle-evt
done-chan done-chan
(λ (resp-chan) (λ (resp-chan)
(channel-put resp-chan events)))))))) (channel-put resp-chan events)))))
(loop)))))
(define f (parameterize ([current-eventspace (make-eventspace)]) (define controller-frame-eventspace (make-eventspace))
(define f (parameterize ([current-eventspace controller-frame-eventspace])
(new frame% [label ""]))) (new frame% [label ""])))
(define b (new button% [label "Done"] [parent f] (define sb (new button% [label "Start"] [parent f]
[callback
(λ (_1 _2)
(sb-callback))]))
(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f]
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(define resp (make-channel)) (define resp (make-channel))
(channel-put done-chan resp) (channel-put done-chan resp)
(show-results (channel-get resp)) (show-results (channel-get resp))
(exit))])) (send db enable #f)
(send sb enable #t))]))
(define (sb-callback)
(send sb enable #f)
(send db enable #t)
(channel-put start-chan #t))
(send f show #t) (send f show #t)
(struct gui-event (start end name) #:prefab) (struct gui-event (start end name) #:prefab)
@ -117,7 +133,12 @@ log message was reported.
[(timeline-info? (vector-ref x 2)) [(timeline-info? (vector-ref x 2))
(timeline-info-milliseconds (vector-ref x 2))] (timeline-info-milliseconds (vector-ref x 2))]
[else [else
(eprintf "unk: ~s\n" x) (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1))
(eprintf "unk: ~s\n" x))
0])) 0]))
(when start-right-away?
(parameterize ([current-eventspace controller-frame-eventspace])
(queue-callback sb-callback)))
(dynamic-require 'drracket #f) (dynamic-require 'drracket #f)