save recent drracket internal error exn records to include in PRs

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^
   ())

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%

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

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)))

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))))

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)
+(define (set-bug-report-info! str thunk [min-height #f])
-  (set! bug-report-infos (cons (bri str thunk) bug-report-infos)))
+  (set! bug-report-infos (cons (bri str thunk min-height) bug-report-infos)))
 
 (define (get-bug-report-infos) bug-report-infos)