diff --git a/collects/drracket/private/drsig.rkt b/collects/drracket/private/drsig.rkt index ab2f01b2ba..c60f237301 100644 --- a/collects/drracket/private/drsig.rkt +++ b/collects/drracket/private/drsig.rkt @@ -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^ ()) diff --git a/collects/drracket/private/help-desk.rkt b/collects/drracket/private/help-desk.rkt index 84d2c00223..1da72e88ca 100644 --- a/collects/drracket/private/help-desk.rkt +++ b/collects/drracket/private/help-desk.rkt @@ -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% diff --git a/collects/drracket/private/init.rkt b/collects/drracket/private/init.rkt index e539b2b73b..8dd4790dc7 100644 --- a/collects/drracket/private/init.rkt +++ b/collects/drracket/private/init.rkt @@ -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 diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 76c0975c8a..11cc12aafe 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -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))) diff --git a/collects/help/private/bug-report-controls.rkt b/collects/help/private/bug-report-controls.rkt index 3bd9de2511..c9e324094c 100644 --- a/collects/help/private/bug-report-controls.rkt +++ b/collects/help/private/bug-report-controls.rkt @@ -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)))) diff --git a/collects/help/private/buginfo.rkt b/collects/help/private/buginfo.rkt index 06cf87b25f..3a1cdab79f 100644 --- a/collects/help/private/buginfo.rkt +++ b/collects/help/private/buginfo.rkt @@ -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)