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.
This commit is contained in:
Robby Findler
parent
58fa3dd6d7
commit
1b7bda5f2a
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user