From 1b7bda5f2afc0960f27f46d33f9980d66949b746 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 26 Nov 2011 21:12:50 -0600 Subject: [PATCH] clean up the way the state of the online expansion GUI is kept. This fixes a bunch of little things, including switch tabs between windows with different states (closing PR 12341) and switching to a non-module language. --- collects/drracket/private/module-language.rkt | 195 ++++++++++-------- 1 file changed, 109 insertions(+), 86 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 77f609b271..7c2b52e870 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -766,7 +766,8 @@ set-expand-error/status update-frame-expand-error expand-error-next - expand-error-prev) + expand-error-prev + hide-module-language-error-panel) (define module-language-online-expand-tab-mixin (mixin (drracket:unit:tab<%>) () @@ -880,34 +881,39 @@ [parent expand-error-multiple-child]) (new close-icon% [parent expand-error-panel] - [callback - (λ () - (send expand-error-parent-panel change-children - (λ (l) (remq expand-error-panel l))))]) + [callback (λ () (send (send (get-current-tab) get-defs) hide-module-language-error-panel))]) (send expand-error-parent-panel change-children (λ (l) (remq expand-error-panel l))) root) (define expand-error-msg #f) (define expand-error-srcloc-count 0) + (define expand-error-hidden? #f) - (define/public (set-expand-error/status msg err? srcloc-count) - (unless (and (equal? expand-error-msg msg) + (define/public (set-expand-error/status hidden? msg err? srcloc-count) + (unless (and (equal? expand-error-hidden? hidden?) + (equal? expand-error-msg msg) (equal? expand-error-srcloc-count srcloc-count)) + (set! expand-error-hidden? hidden?) (set! expand-error-msg msg) (set! expand-error-srcloc-count srcloc-count) (when expand-error-message + (send expand-error-parent-panel change-children + (λ (l) (if hidden? + (if (memq expand-error-panel l) + (remq expand-error-panel l) + l) + (if (memq expand-error-panel l) + l + (append l (list expand-error-panel)))))) + (send expand-error-message set-msg expand-error-msg err?) (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) @@ -976,74 +982,78 @@ (send small-control-font get-size-in-pixels))) (define running-canvas - (new (class canvas% - (inherit get-dc popup-menu refresh get-client-size) - (define/override (on-paint) + (let ([tlw this]) + (new (class canvas% + (inherit get-dc popup-menu refresh get-client-size) + (define/override (on-paint) + (let ([dc (get-dc)]) + (define colors-to-draw + (cond + [(not (in-module-language tlw)) #f] + [(preferences:get 'drracket:online-compilation-default-off) + colors] + [else (list "red")])) + (when colors-to-draw + (send dc set-smoothing 'aligned) + (send dc set-pen "black" 1 'transparent) + (send dc set-text-foreground "darkred") + (send dc set-font parens-mismatch-font) + (define-values (tw th td ta) (send dc get-text-extent parens-mismatch-str)) + (define-values (cw ch) (get-client-size)) + (cond + [(list? colors-to-draw) + (define len (length colors-to-draw)) + (for ([color (in-list colors-to-draw)] + [i (in-naturals)]) + (if color + (send dc set-brush color 'solid) + (send dc set-brush "black" 'transparent)) + (send dc draw-arc + (- (/ cw 2) (/ ball-size 2)) + (- (/ ch 2) (/ ball-size 2)) + ball-size ball-size + (+ (* pi 1/2) (* 2 pi (/ i len))) + (+ (* pi 1/2) (* 2 pi (/ (+ i 1) len)))))] + [(eq? colors-to-draw 'parens) + (send dc draw-text parens-mismatch-str + (- (/ cw 2) (/ tw 2)) + (- (/ ch 2) (/ th 2)))])))) + (define cb-proc (λ (sym new-val) + (set! colors #f) + (refresh))) + (preferences:add-callback 'drracket:online-compilation-default-off cb-proc #t) + (define/override (on-event evt) + (cond + [(not (in-module-language tlw)) (void)] + [(send evt button-down?) + (define menu (new popup-menu%)) + (define on? (preferences:get 'drracket:online-compilation-default-off)) + (new menu-item% + [parent menu] + [label (if on? + "Disable online compilation" + "Enable online compilation")] + [callback + (λ args + (preferences:set 'drracket:online-compilation-default-off (not on?)))]) + (popup-menu menu (send evt get-x) (send evt get-y))] + [(send evt entering?) + (show-tooltip)] + [(send evt leaving?) + (hide-tooltip)])) + (super-new [style '(transparent)] + [parent (get-info-panel)] + [stretchable-width #f] + [stretchable-height #f] + [min-width 10] + [min-height 10]) + + (inherit min-width min-height) (let ([dc (get-dc)]) - (define colors-to-draw - (if (preferences:get 'drracket:online-compilation-default-off) - colors - (list "red"))) - (when colors-to-draw - (send dc set-smoothing 'aligned) - (send dc set-pen "black" 1 'transparent) - (send dc set-text-foreground "darkred") - (send dc set-font parens-mismatch-font) - (define-values (tw th td ta) (send dc get-text-extent parens-mismatch-str)) - (define-values (cw ch) (get-client-size)) - (cond - [(list? colors-to-draw) - (define len (length colors-to-draw)) - (for ([color (in-list colors-to-draw)] - [i (in-naturals)]) - (if color - (send dc set-brush color 'solid) - (send dc set-brush "black" 'transparent)) - (send dc draw-arc - (- (/ cw 2) (/ ball-size 2)) - (- (/ ch 2) (/ ball-size 2)) - ball-size ball-size - (+ (* pi 1/2) (* 2 pi (/ i len))) - (+ (* pi 1/2) (* 2 pi (/ (+ i 1) len)))))] - [(eq? colors-to-draw 'parens) - (send dc draw-text parens-mismatch-str - (- (/ cw 2) (/ tw 2)) - (- (/ ch 2) (/ th 2)))])))) - (define cb-proc (λ (sym new-val) - (set! colors #f) - (refresh))) - (preferences:add-callback 'drracket:online-compilation-default-off cb-proc #t) - (define/override (on-event evt) - (cond - [(send evt button-down?) - (define menu (new popup-menu%)) - (define on? (preferences:get 'drracket:online-compilation-default-off)) - (new menu-item% - [parent menu] - [label (if on? - "Disable online compilation" - "Enable online compilation")] - [callback - (λ args - (preferences:set 'drracket:online-compilation-default-off (not on?)))]) - (popup-menu menu (send evt get-x) (send evt get-y))] - [(send evt entering?) - (show-tooltip)] - [(send evt leaving?) - (hide-tooltip)])) - (super-new [style '(transparent)] - [parent (get-info-panel)] - [stretchable-width #f] - [stretchable-height #f] - [min-width 10] - [min-height 10]) - - (inherit min-width min-height) - (let ([dc (get-dc)]) - (send dc set-font parens-mismatch-font) - (define-values (w h d a) (send dc get-text-extent parens-mismatch-str)) - (min-width (ceiling (inexact->exact (max w ball-size)))) - (min-height (ceiling (inexact->exact (max h ball-size)))))))))) + (send dc set-font parens-mismatch-font) + (define-values (w h d a) (send dc get-text-extent parens-mismatch-str)) + (min-width (ceiling (inexact->exact (max w ball-size)))) + (min-height (ceiling (inexact->exact (max h ball-size))))))))))) (define error-message% (class canvas% @@ -1196,20 +1206,22 @@ ;; thus, they are where we check the preference ;; before doing anything - (define/private (buffer-modified) (when (and (preferences:get 'drracket:online-compilation-default-off) (> (processor-count) 1)) (clear-old-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) - (stop-place-running) - (set! compilation-out-of-date? #t) - (when (eq? (send tlw get-current-tab) (get-tab)) - (send tmr stop) - (send tmr start 250 #t)))))) + (cond + [(in-module-language tlw) + (send (get-tab) show-bkg-running 'nothing #f) + (stop-place-running) + (set! compilation-out-of-date? #t) + (when (eq? (send tlw get-current-tab) (get-tab)) + (send tmr stop) + (send tmr start 250 #t))] + [else + (hide-module-language-error-panel)])))) (define/public (restart-place) (when (and (preferences:get 'drracket:online-compilation-default-off) @@ -1258,6 +1270,7 @@ (define status-line-open? #f) + (define error/status-message-hidden? #f) (define error/status-message-str "") (define error/status-message-err? #f) (define error-message-srclocs '()) @@ -1275,9 +1288,13 @@ (update-frame-expand-error))) (define/public (update-frame-expand-error) (send (send (get-tab) get-frame) set-expand-error/status + error/status-message-hidden? error/status-message-str error/status-message-err? (length error-message-srclocs))) + (define/public (hide-module-language-error-panel) + (set! error/status-message-hidden? #t) + (update-frame-expand-error)) (define/public (expand-error-next) (define candidates (filter (λ (error-message-srcloc) @@ -1374,6 +1391,7 @@ (error-range (- pos 1) (+ pos span -1) #f))) (set-error-ranges-from-online-error-ranges (vector-ref res 2)) (invalidate-online-error-ranges) + (set! error/status-message-hidden? #f) (update-frame-expand-error)) (define/private (show-error-as-highlighted-regions res) @@ -1389,6 +1407,7 @@ (define span (vector-ref range 1)) (highlight-range (- pos 1) (+ pos span -1) "gold"))) (set-error-ranges-from-online-error-ranges (vector-ref res 2)) + (set! error/status-message-hidden? #f) (update-frame-expand-error)) (define online-error-ranges '()) @@ -1545,6 +1564,10 @@ (when success? (buffer-modified)) (inner (void) after-load-file success?)) + (define/augment (after-set-next-settings new-settings) + (buffer-modified) + (inner (void) after-set-next-settings new-settings)) + (super-new)))