suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

clean up the way the state of the online expansion GUI is kept.

Browse Source 
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.
This commit is contained in:
Robby Findler 2011-11-26 21:12:50 -06:00
parent 58fa3dd6d7
commit 1b7bda5f2a
1 changed files with 109 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

195
collects/drracket/private/module-language.rkt
View File

@ -766,7 +766,8 @@
set-expand-error/status set-expand-error/status
update-frame-expand-error update-frame-expand-error
expand-error-next expand-error-next
expand-error-prev) expand-error-prev
hide-module-language-error-panel)
(define module-language-online-expand-tab-mixin (define module-language-online-expand-tab-mixin
(mixin (drracket:unit:tab<%>) () (mixin (drracket:unit:tab<%>) ()
@ -880,34 +881,39 @@
[parent expand-error-multiple-child]) [parent expand-error-multiple-child])
(new close-icon% (new close-icon%
[parent expand-error-panel] [parent expand-error-panel]
[callback [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))))])
(send expand-error-parent-panel change-children (λ (l) (remq expand-error-panel l))) (send expand-error-parent-panel change-children (λ (l) (remq expand-error-panel l)))
root) root)
(define expand-error-msg #f) (define expand-error-msg #f)
(define expand-error-srcloc-count 0) (define expand-error-srcloc-count 0)
(define expand-error-hidden? #f)
(define/public (set-expand-error/status msg err? srcloc-count) (define/public (set-expand-error/status hidden? msg err? srcloc-count)
(unless (and (equal? expand-error-msg msg) (unless (and (equal? expand-error-hidden? hidden?)
(equal? expand-error-msg msg)
(equal? expand-error-srcloc-count srcloc-count)) (equal? expand-error-srcloc-count srcloc-count))
(set! expand-error-hidden? hidden?)
(set! expand-error-msg msg) (set! expand-error-msg msg)
(set! expand-error-srcloc-count srcloc-count) (set! expand-error-srcloc-count srcloc-count)
(when expand-error-message (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 (cond
[err? [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 (send expand-error-button-parent-panel active-child
(cond (cond
[(= srcloc-count 0) expand-error-zero-child] [(= srcloc-count 0) expand-error-zero-child]
[(= srcloc-count 1) expand-error-single-child] [(= srcloc-count 1) expand-error-single-child]
[else expand-error-multiple-child]))] [else expand-error-multiple-child]))]
[else [else
(send expand-error-message set-msg expand-error-msg err?)
(send expand-error-button-parent-panel active-child expand-error-zero-child)])))) (send expand-error-button-parent-panel active-child expand-error-zero-child)]))))
(define/augment (on-tab-change from-tab to-tab) (define/augment (on-tab-change from-tab to-tab)
@ -976,74 +982,78 @@
(send small-control-font get-size-in-pixels))) (send small-control-font get-size-in-pixels)))
(define running-canvas (define running-canvas
(new (class canvas% (let ([tlw this])
(inherit get-dc popup-menu refresh get-client-size) (new (class canvas%
(define/override (on-paint) (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)]) (let ([dc (get-dc)])
(define colors-to-draw (send dc set-font parens-mismatch-font)
(if (preferences:get 'drracket:online-compilation-default-off) (define-values (w h d a) (send dc get-text-extent parens-mismatch-str))
colors (min-width (ceiling (inexact->exact (max w ball-size))))
(list "red"))) (min-height (ceiling (inexact->exact (max h ball-size)))))))))))
(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))))))))))
(define error-message% (define error-message%
(class canvas% (class canvas%
@ -1196,20 +1206,22 @@
;; thus, they are where we check the preference ;; thus, they are where we check the preference
;; before doing anything ;; before doing anything
(define/private (buffer-modified) (define/private (buffer-modified)
(when (and (preferences:get 'drracket:online-compilation-default-off) (when (and (preferences:get 'drracket:online-compilation-default-off)
(> (processor-count) 1)) (> (processor-count) 1))
(clear-old-error) (clear-old-error)
(reset-frame-expand-error #t) (reset-frame-expand-error #t)
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when (in-module-language tlw) (cond
(send (get-tab) show-bkg-running 'nothing #f) [(in-module-language tlw)
(stop-place-running) (send (get-tab) show-bkg-running 'nothing #f)
(set! compilation-out-of-date? #t) (stop-place-running)
(when (eq? (send tlw get-current-tab) (get-tab)) (set! compilation-out-of-date? #t)
(send tmr stop) (when (eq? (send tlw get-current-tab) (get-tab))
(send tmr start 250 #t)))))) (send tmr stop)
(send tmr start 250 #t))]
[else
(hide-module-language-error-panel)]))))
(define/public (restart-place) (define/public (restart-place)
(when (and (preferences:get 'drracket:online-compilation-default-off) (when (and (preferences:get 'drracket:online-compilation-default-off)
@ -1258,6 +1270,7 @@
(define status-line-open? #f) (define status-line-open? #f)
(define error/status-message-hidden? #f)
(define error/status-message-str "") (define error/status-message-str "")
(define error/status-message-err? #f) (define error/status-message-err? #f)
(define error-message-srclocs '()) (define error-message-srclocs '())
@ -1275,9 +1288,13 @@
(update-frame-expand-error))) (update-frame-expand-error)))
(define/public (update-frame-expand-error) (define/public (update-frame-expand-error)
(send (send (get-tab) get-frame) set-expand-error/status (send (send (get-tab) get-frame) set-expand-error/status
error/status-message-hidden?
error/status-message-str error/status-message-str
error/status-message-err? error/status-message-err?
(length error-message-srclocs))) (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/public (expand-error-next)
(define candidates (filter (λ (error-message-srcloc) (define candidates (filter (λ (error-message-srcloc)
@ -1374,6 +1391,7 @@
(error-range (- pos 1) (+ pos span -1) #f))) (error-range (- pos 1) (+ pos span -1) #f)))
(set-error-ranges-from-online-error-ranges (vector-ref res 2)) (set-error-ranges-from-online-error-ranges (vector-ref res 2))
(invalidate-online-error-ranges) (invalidate-online-error-ranges)
(set! error/status-message-hidden? #f)
(update-frame-expand-error)) (update-frame-expand-error))
(define/private (show-error-as-highlighted-regions res) (define/private (show-error-as-highlighted-regions res)
@ -1389,6 +1407,7 @@
(define span (vector-ref range 1)) (define span (vector-ref range 1))
(highlight-range (- pos 1) (+ pos span -1) "gold"))) (highlight-range (- pos 1) (+ pos span -1) "gold")))
(set-error-ranges-from-online-error-ranges (vector-ref res 2)) (set-error-ranges-from-online-error-ranges (vector-ref res 2))
(set! error/status-message-hidden? #f)
(update-frame-expand-error)) (update-frame-expand-error))
(define online-error-ranges '()) (define online-error-ranges '())
@ -1545,6 +1564,10 @@
(when success? (buffer-modified)) (when success? (buffer-modified))
(inner (void) after-load-file success?)) (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))) (super-new)))