diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 4ef50ada9a..33f43424f7 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -56,6 +56,14 @@ module browser threading seems wrong. (λ args (apply fprintf op args)))) + ;; code copied from framework/private/frame.rkt + (define checkout-or-nightly? + (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (directory-exists? (collection-path "repo-time-stamp"))) + (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (let ([fw (collection-path "framework")]) + (directory-exists? (build-path fw 'up 'up ".git")))))) + (define-unit unit@ (import [prefix help-desk: drracket:help-desk^] [prefix drracket:app: drracket:app^] @@ -599,6 +607,13 @@ module browser threading seems wrong. (end-edit-sequence) (inner (void) after-load-file success?)) + (define/augment (on-lexer-valid valid?) + (inner (void) on-lexer-valid valid?) + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (send f set-color-status! valid?)))) + (inherit is-modified? run-after-edit-sequence) (define/override (set-modified mod?) (super set-modified mod?) @@ -3984,6 +3999,36 @@ module browser threading seems wrong. (define/public (get-button-panel) button-panel) (inherit get-info-panel) + + (define color-status-canvas + (and checkout-or-nightly? + (let () + (define on-string "()") + (define color-status-canvas + (new canvas% + [parent (get-info-panel)] + [style '(transparent)] + [stretchable-width #f] + [paint-callback + (λ (c dc) + (when (number? th) + (cond + [color-valid? + (send dc erase)] + [else + (let-values ([(cw ch) (send c get-client-size)]) + (send dc set-font small-control-font) + (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2))))])))])) + (define-values (tw th ta td) (send (send color-status-canvas get-dc) get-text-extent on-string small-control-font)) + (send color-status-canvas min-width (inexact->exact (ceiling tw))) + color-status-canvas))) + (define color-valid? #t) + (define/public (set-color-status! v?) + (when color-status-canvas + (set! color-valid? v?) + (send color-status-canvas on-paint) + (send color-status-canvas flush))) + (define running-canvas (new running-canvas% [parent (get-info-panel)])) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index d343afb481..3bdf85e4ec 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -2445,6 +2445,7 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) +;; code copied to drracket/private/unit.rkt (define checkout-or-nightly? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repo-time-stamp"))) @@ -2473,8 +2474,10 @@ (define/override (on-paint) (cond [on? + (define dc (get-dc)) + (send dc set-font small-control-font) (let-values ([(cw ch) (get-client-size)]) - (send (get-dc) draw-text indicator + (send dc draw-text indicator (- (/ cw 2) (/ indicator-width 2)) (- (/ ch 2) (/ indicator-height 2))))])) (define/public (set-on? new-on?) @@ -2487,9 +2490,8 @@ (super-new [stretchable-width #f] [style '(transparent)]) - (send (get-dc) set-font small-control-font) (define-values (indicator-width indicator-height) - (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator small-control-font)]) (values tw th))) (min-width (+ (inexact->exact (ceiling indicator-width)) 4))))