use new syntax colorer hooks to provide feedback about syntax coloring in the definitions window in drracket

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)]))
         

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))))