From c264ece3f485dbb9ec03822c15bc86603102aa21 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 21 Sep 2011 08:34:56 -0500 Subject: [PATCH] added status messages to the (now often empty) error message bar --- collects/drracket/private/module-language.rkt | 94 +++++++++++-------- .../drracket/private/syncheck/online-comp.rkt | 5 +- .../private/english-string-constants.rkt | 2 + 3 files changed, 58 insertions(+), 43 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 9e8acceda5..cadc98fa97 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -763,7 +763,7 @@ show-bkg-running frame-show-bkg-running restart-place - set-expand-error + set-expand-error/status update-frame-expand-error expand-error-next expand-error-prev) @@ -839,9 +839,11 @@ [stretchable-height #f] [parent expand-error-parent-panel])) - (set! expand-error-message (new error-message% [parent expand-error-panel] + (set! expand-error-message (new error-message% + [parent expand-error-panel] [stretchable-width #t] - [msg "hi"])) + [msg "hi"] + [err? #f])) (set! expand-error-button-parent-panel (new panel:single% [stretchable-width #f] @@ -883,24 +885,25 @@ (define expand-error-msg #f) (define expand-error-srcloc-count 0) - (define/public (set-expand-error msg srcloc-count) + (define/public (set-expand-error/status msg err? srcloc-count) (unless (and (equal? expand-error-msg msg) (equal? expand-error-srcloc-count srcloc-count)) (set! expand-error-msg msg) (set! expand-error-srcloc-count srcloc-count) - (cond - [expand-error-msg - (send expand-error-message set-msg expand-error-msg) - (send expand-error-parent-panel change-children - (λ (l) (append (remq expand-error-panel l) (list expand-error-panel)))) - (send expand-error-button-parent-panel active-child - (cond - [(= srcloc-count 0) expand-error-zero-child] - [(= srcloc-count 1) expand-error-single-child] - [else expand-error-multiple-child]))] - [else - (send expand-error-message set-msg "") - (send expand-error-button-parent-panel active-child expand-error-zero-child)]))) + (when expand-error-message + (cond + [err? + (send expand-error-message set-msg expand-error-msg err?) + (send expand-error-parent-panel change-children + (λ (l) (append (remq expand-error-panel l) (list expand-error-panel)))) + (send expand-error-button-parent-panel active-child + (cond + [(= srcloc-count 0) expand-error-zero-child] + [(= srcloc-count 1) expand-error-single-child] + [else expand-error-multiple-child]))] + [else + (send expand-error-message set-msg expand-error-msg err?) + (send expand-error-button-parent-panel active-child expand-error-zero-child)])))) (define/augment (on-tab-change from-tab to-tab) (send (send to-tab get-defs) restart-place) @@ -1037,23 +1040,24 @@ (define error-message% (class canvas% - (init-field msg) + (init-field msg err?) (inherit refresh get-dc get-client-size) - (define/public (set-msg m) - (set! msg m) + (define/public (set-msg _msg _err?) + (set! msg _msg) + (set! err? _err?) (refresh)) (define/override (on-paint) (define dc (get-dc)) (define-values (cw ch) (get-client-size)) - (send dc set-font error-font) + (send dc set-font (if err? error-font normal-control-font)) (define-values (tw th td ta) (send dc get-text-extent msg)) - (send dc set-text-foreground "firebrick") + (send dc set-text-foreground (if err? "firebrick" "black")) (send dc draw-text msg 2 (- (/ ch 2) (/ th 2)))) (super-new [style '(transparent)]) (inherit min-height) (let () - (send (get-dc) set-font error-font) + (send (get-dc) set-font (if err? error-font normal-control-font)) (define-values (tw th td ta) (send (get-dc) get-text-extent msg)) (min-height (inexact->exact (ceiling th)))))) @@ -1175,7 +1179,7 @@ (when (and (preferences:get 'drracket:online-compilation-default-off) (> (processor-count) 1)) (clear-old-error) - (reset-frame-expand-error) + (reset-frame-expand-error #t) (let ([tlw (get-top-level-window)]) (when (in-module-language tlw) (send (get-tab) show-bkg-running 'nothing #f) @@ -1207,7 +1211,7 @@ (λ (res) (show-results res))) (when status-line-open? (clear-old-error) - (reset-frame-expand-error)) + (reset-frame-expand-error #t)) (send (get-tab) show-bkg-running 'running sc-online-expansion-running))))) (define/private (fetch-data-to-send) @@ -1232,19 +1236,27 @@ (define status-line-open? #f) - (define error-message-str #f) + (define error/status-message-str #f) + (define error/status-message-err? #f) (define error-message-srclocs '()) - (define/private (reset-frame-expand-error) - (unless (and (eq? error-message-str #f) - (eq? error-message-srclocs '())) - (set! error-message-str #f) + (define/private (reset-frame-expand-error pending?) + (define new-error/status-message-str + (if pending? + (string-constant online-expansion-pending) + (string-constant online-expansion-finished))) + (unless (and (equal? error/status-message-str new-error/status-message-str) + (eq? error-message-srclocs '()) + (eq? error/status-message-err? #f)) + (set! error/status-message-str new-error/status-message-str) (set! error-message-srclocs '()) + (set! error/status-message-err? #f) (update-frame-expand-error))) (define/public (update-frame-expand-error) - (send (send (get-tab) get-frame) set-expand-error - error-message-str + (send (send (get-tab) get-frame) set-expand-error/status + error/status-message-str + error/status-message-err? (length error-message-srclocs))) - + (define/public (expand-error-next) (define candidates (filter (λ (error-message-srcloc) (> (- (vector-ref error-message-srcloc 0) 1) @@ -1295,18 +1307,18 @@ [(access-violation) (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1))) (clear-old-error) - (reset-frame-expand-error)] + (reset-frame-expand-error #f)] [(abnormal-termination) (send (get-tab) show-bkg-running 'failed sc-abnormal-termination) (clear-old-error) - (reset-frame-expand-error)] + (reset-frame-expand-error #f)] [(no-errors) (send (get-tab) show-bkg-running 'nothing #f) (clear-old-error) - (reset-frame-expand-error)] + (reset-frame-expand-error #f)] [(handler-results) (clear-old-error) - (reset-frame-expand-error) + (reset-frame-expand-error #f) ;; inform the installed handlers that something has come back (for ([key-val (in-list (vector-ref res 1))]) (define that-key (list-ref key-val 0)) @@ -1324,13 +1336,14 @@ (send (get-tab) show-bkg-running 'reader-in-defs-error (gui-utils:format-literal-label "~a" (vector-ref res 1))) (clear-old-error) - (reset-frame-expand-error)) + (reset-frame-expand-error #f)) (define/private (show-error-in-margin res) (define tlw (send (get-tab) get-frame)) (send (get-tab) show-bkg-running 'nothing #f) - (set! error-message-str (vector-ref res 1)) + (set! error/status-message-str (vector-ref res 1)) (set! error-message-srclocs (vector-ref res 2)) + (set! error/status-message-err? #t) (clear-old-error) (set-online-error-ranges (for/list ([range (in-list (vector-ref res 2))]) @@ -1344,8 +1357,9 @@ (define/private (show-error-as-highlighted-regions res) (define tlw (send (get-tab) get-frame)) (send (get-tab) show-bkg-running 'nothing #f) - (set! error-message-str (vector-ref res 1)) + (set! error/status-message-str (vector-ref res 1)) (set! error-message-srclocs (vector-ref res 2)) + (set! error/status-message-err? #t) (clear-old-error) (set! online-highlighted-errors (for/list ([range (in-list (vector-ref res 2))]) diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 41e7c84fa6..e57a662653 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -54,8 +54,7 @@ (super-new))) (define (go expanded path the-source) - (time - (with-handlers ((exn:fail? (λ (x) + (with-handlers ((exn:fail? (λ (x) (printf "~a\n" (exn-message x)) (printf "---\n") (for ([x (in-list @@ -75,4 +74,4 @@ (parameterize ([current-annotations obj]) (expanded-expression expanded) (expansion-completed)) - (send obj get-trace)))) + (send obj get-trace))) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 81cf8c7a28..3c85b24fb9 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -224,6 +224,8 @@ please adhere to these guidelines: (abnormal-termination "Online expansion terminated abnormally") (jump-to-error "Jump to Error") (online-expansion-is-disabled "Online expansion is disabled") + (online-expansion-pending "Online expansion pending ...") + (online-expansion-finished "Online expansion finished without errors") ;; the online expansion preferences pane (online-expansion "Online expansion") ;; title of prefs pane