1#lang racket/unit
2  (require string-constants
3           drracket/private/drsig
4           racket/gui/base
5           racket/list
6           racket/class
7           framework)
8
9  (import [prefix drracket: drracket:interface^]
10          [prefix drracket:rep: drracket:rep^])
11  (export drracket:init/int^)
12
13  (define original-output-port (current-output-port))
14  (define original-error-port (current-error-port))
15
16  (define primitive-eval (current-eval))
17  (define primitive-load (current-load))
18
19  (define system-logger (current-logger))
20
21  (define system-custodian (current-custodian))
22  (define system-eventspace (current-eventspace))
23  (define system-thread (current-thread))
24  (define system-namespace (current-namespace))
25  (define first-dir (current-directory))
26  (define system-inspector (current-inspector))
27
28  (define error-display-eventspace (make-eventspace))
29
30  (define original-error-display-handler (error-display-handler))
31  (define original-print (current-print))
32
33  (define error-display-handler-message-box-title
34    (make-parameter (string-constant drscheme-internal-error)))
35
36  (define system-security-guard (current-security-guard))
37
38  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39  ;;
40  ;;  internal error display support
41  ;;
42
43  (define error-display-chan (make-channel))
44  (define number-of-errors-to-save 5)
45  (thread
46   (λ ()
47     (define-struct recent (msg when))
48     (define currently-visible-chan (make-channel))
49     (let loop ([recently-seen-errors/unfiltered '()]
50                [currently-visible #f])
51       (sync
52        (handle-evt
53         error-display-chan
54         (λ (msg+exn)
55           (define recently-seen-errors
56             ;; recent errors are ones less than 5 minutes old
57             (let ([now (current-seconds)])
58               (filter (λ (x) (<= (+ (recent-when x) (* 60 5)) now))
59                       recently-seen-errors/unfiltered)))
60           (define-values (msg exn) (apply values msg+exn))
61           (cond
62             [currently-visible
63              ;; drop errors when we have one waiting to be clicked on
64              (loop recently-seen-errors #t)]
65             [(ormap (λ (x) (equal? msg (recent-msg x)))
66                     recently-seen-errors)
67              ;; drop the error if we've seen it recently
68              (loop recently-seen-errors #f)]
69             [else
70              ;; show the error
71              (define title (error-display-handler-message-box-title))
72              (define text (let ([p (open-output-string)])
73                             (parameterize ([current-error-port p]
74                                            [current-output-port p])
75                               (original-error-display-handler msg exn))
76                             (get-output-string p)))
77
78              (parameterize ([current-eventspace error-display-eventspace]
79                             [current-custodian system-custodian])
80                (queue-callback
81                 (λ ()
82                   (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin)
83                   (channel-put currently-visible-chan #f))))
84              (loop (cons (make-recent msg (current-seconds)) recently-seen-errors)
85                    #t)])))
86        (handle-evt
87         currently-visible-chan
88         (λ (val)
89           (loop recently-seen-errors/unfiltered #f)))))))
90
91  ;; override error-display-handler to duplicate the error
92  ;; message in both the standard place (as defined by the
93  ;; current error-display-handler) and in a message box
94  ;; identifying the error as a drracket internal error.
95  (error-display-handler
96   (λ (msg exn)
97     ;; this  may raise an exception if the port is gone.
98     (with-handlers ([exn:fail? (λ (x) (void))])
99       (original-error-display-handler msg exn))
100     (channel-put error-display-chan (list msg exn))
101
102     ;; try to end any unclosed edit-sequences in any definitions
103     ;; texts or interactions texts. That is, we try to recover a
104     ;; little bit from errors that are raised in the dynamic
105     ;; extent of an edit-sequence.
106     (when (eq? (current-thread) (eventspace-handler-thread system-eventspace))
107       (for ([f (in-list (get-top-level-windows))])
108         (when (is-a? f drracket:unit:frame<%>)
109           (let loop ([o f])
110             (cond
111               [(is-a? o editor-canvas%)
112                (define t (send o get-editor))
113                (when (or (is-a? t drracket:unit:definitions-text<%>)
114                          (is-a? t drracket:rep:text<%>))
115                  (let loop ()
116                    (when (send t in-edit-sequence?)
117                      (send t end-edit-sequence)
118                      (loop))))]
119               [(is-a? o area-container<%>)
120                (for ([c (in-list (send o get-children))])
121                  (loop c))])))))))
122