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