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

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

Browse Source
This commit is contained in:
Robby Findler 2011-01-05 20:37:55 -06:00
parent 92d9ce38d3
commit 33cb5a8b6f
2 changed files with 50 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/drracket/private/unit.rkt
View File

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

8
collects/framework/private/frame.rkt
View File

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