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

save recent drracket internal error exn records to include in PRs

Browse Source
This commit is contained in:
Robby Findler 2013-06-17 17:52:27 -05:00
parent 332ce02127
commit 3a09814c64
6 changed files with 61 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drracket/private/drsig.rkt
View File

@ -139,7 +139,8 @@
system-eventspace
system-namespace
system-security-guard
first-dir))
first-dir
get-last-N-errors))
(define-signature drracket:language-configuration-cm^
())

22
collects/drracket/private/help-desk.rkt
View File

@ -11,7 +11,8 @@
"drsig.rkt")
(import [prefix drracket:frame: drracket:frame^]
[prefix drracket:language-configuration: drracket:language-configuration/internal^])
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
[prefix drracket:init: drracket:init^])
(export drracket:help-desk^)
(define (-add-help-desk-font-prefs b) '(add-help-desk-font-prefs b))
@ -31,6 +32,25 @@
(send language marshall-settings settings)))))
(set-bug-report-info! "Computer Language" get-computer-language-info)
(set-bug-report-info! "Recent Internal Errors"
(λ ()
(define errs (drracket:init:get-last-N-errors))
(define sp (open-output-string))
(unless (null? errs)
(fprintf sp "Saved ~a internal error~a:\n\n"
(length errs)
(if (= 1 (length errs)) "" "s")))
(parameterize ([current-error-port sp])
(define first? #t)
(for ([err (in-list errs)])
(if first?
(set! first? #f)
(eprintf "\n\n"))
(drracket:init:original-error-display-handler
(list-ref err 0)
(list-ref err 1))))
(get-output-string sp))
100)
(define lang-message%
(class canvas%

28
collects/drracket/private/init.rkt
View File

@ -2,6 +2,7 @@
(require string-constants
"drsig.rkt"
racket/gui/base
racket/list
framework)
@ -37,11 +38,14 @@
;;
(define error-display-chan (make-channel))
(define get-last-N-errors-chan (make-channel))
(define number-of-errors-to-save 5)
(thread
(λ ()
(define-struct recent (msg when))
(define currently-visible-chan (make-channel))
(let loop ([recently-seen-errors/unfiltered '()]
[last-N-errors '()]
[currently-visible #f])
(sync
(handle-evt
@ -52,15 +56,19 @@
(let ([now (current-seconds)])
(filter (λ (x) (<= (+ (recent-when x) (* 60 5)) now))
recently-seen-errors/unfiltered)))
(define new-last-N-errors (cons msg+exn
(take last-N-errors
(min (- number-of-errors-to-save 1)
(length last-N-errors)))))
(define-values (msg exn) (apply values msg+exn))
(cond
[currently-visible
;; drop errors when we have one waiting to be clicked on
(loop recently-seen-errors #t)]
(loop recently-seen-errors new-last-N-errors #t)]
[(ormap (λ (x) (equal? msg (recent-msg x)))
recently-seen-errors)
;; drop the error if we've seen it recently
(loop recently-seen-errors #f)]
(loop recently-seen-errors new-last-N-errors #f)]
[else
;; show the error
(define title (error-display-handler-message-box-title))
@ -77,11 +85,25 @@
(message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin)
(channel-put currently-visible-chan #f))))
(loop (cons (make-recent msg (current-seconds)) recently-seen-errors)
new-last-N-errors
#t)])))
(handle-evt
get-last-N-errors-chan
(λ (c)
(channel-put c last-N-errors)
(loop
(loop recently-seen-errors/unfiltered
last-N-errors
currently-visible))))
(handle-evt
currently-visible-chan
(λ (val)
(loop recently-seen-errors/unfiltered #f)))))))
(loop recently-seen-errors/unfiltered last-N-errors #f)))))))
(define (get-last-N-errors)
(define c (make-channel))
(channel-put get-last-N-errors-chan c)
(channel-get c))
;; override error-display-handler to duplicate the error
;; message in both the standard place (as defined by the

1
collects/drracket/private/unit.rkt
View File

@ -1202,6 +1202,7 @@ module browser threading seems wrong.
(string-constant change-to-horizontal-alignment))]
[callback
(λ (a b)
(car)
(preferences:set 'drracket:defs/ints-horizontal vertical?)
(set-orientation vertical?))])
(popup-menu menu (send evt get-x) (send evt get-y)))

8
collects/help/private/bug-report-controls.rkt
View File

@ -273,8 +273,14 @@
(let ([field
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void "")))])
(new text-field%
[label #f]
[parent panel]
[callback void]
[init-value ""]
[min-height (bri-min-height bri)])))])
(send field set-value (bri-value bri))
(send (send field get-editor) set-position 0)
field))
#f
#:top-panel synthesized-panel))))

9
collects/help/private/buginfo.rkt
View File

@ -3,14 +3,15 @@
(provide set-bug-report-info!
get-bug-report-infos
bri-label
bri-value)
bri-value
bri-min-height)
(struct bri (label get-value) #:transparent)
(struct bri (label get-value min-height) #:transparent)
(define (bri-value bri) ((bri-get-value bri)))
(define bug-report-infos null)
(define (set-bug-report-info! str thunk)
(set! bug-report-infos (cons (bri str thunk) bug-report-infos)))
(define (set-bug-report-info! str thunk [min-height #f])
(set! bug-report-infos (cons (bri str thunk min-height) bug-report-infos)))
(define (get-bug-report-infos) bug-report-infos)