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

removed the check syntax mode support

Browse Source
This commit is contained in:
Robby Findler 2012-07-17 12:24:19 -05:00
parent 3463f4233e
commit a66c735b82
4 changed files with 20 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/drracket/private/syncheck/annotate.rkt
View File

@ -9,20 +9,20 @@
;; color : syntax[original] str -> void ;; color : syntax[original] str -> void
;; colors the syntax with style-name's style ;; colors the syntax with style-name's style
(define (color stx style-name mode) (define (color stx style-name)
(let ([source (find-source-editor stx)]) (let ([source (find-source-editor stx)])
(when (and (syntax-position stx) (when (and (syntax-position stx)
(syntax-span stx)) (syntax-span stx))
(let ([pos (- (syntax-position stx) 1)] (let ([pos (- (syntax-position stx) 1)]
[span (syntax-span stx)]) [span (syntax-span stx)])
(color-range source pos (+ pos span) style-name mode))))) (color-range source pos (+ pos span) style-name)))))
;; color-range : text start finish style-name ;; color-range : text start finish style-name
;; colors a range in the text based on `style-name' ;; colors a range in the text based on `style-name'
(define (color-range source start finish style-name mode) (define (color-range source start finish style-name)
(define defs (current-annotations)) (define defs (current-annotations))
(when defs (when defs
(send defs syncheck:color-range source start finish style-name mode))) (send defs syncheck:color-range source start finish style-name)))
;; add-mouse-over : syntax[original] string -> void ;; add-mouse-over : syntax[original] string -> void
;; registers the range in the editor so that a mouse over ;; registers the range in the editor so that a mouse over

120
collects/drracket/private/syncheck/gui.rkt
View File

@ -79,10 +79,6 @@ If the namespace does not, they are colored the unbound color.
;; be < 50ms) ;; be < 50ms)
(define syncheck-arrow-delay 100) (define syncheck-arrow-delay 100)
(preferences:set-default 'drracket:syncheck-mode 'default-mode
(λ (x) (memq x '(default-mode
my-obligations-mode
client-obligations-mode))))
(let ([number-between-zero-and-one? (let ([number-between-zero-and-one?
(λ (x) (and (number? x) (<= 0 x 1)))]) (λ (x) (and (number? x) (<= 0 x 1)))])
(preferences:set-default (preferences:set-default
@ -354,7 +350,6 @@ If the namespace does not, they are colored the unbound color.
;; cleanup-texts : (or/c #f (listof text)) ;; cleanup-texts : (or/c #f (listof text))
(define cleanup-texts #f) (define cleanup-texts #f)
(define style-mapping #f)
;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))]
;; this is a private field ;; this is a private field
@ -490,8 +485,7 @@ If the namespace does not, they are colored the unbound color.
(set! tacked-hash-table (make-hasheq)) (set! tacked-hash-table (make-hasheq))
(set! arrow-records (make-hasheq)) (set! arrow-records (make-hasheq))
(set! bindings-table (make-hash)) (set! bindings-table (make-hash))
(set! cleanup-texts '()) (set! cleanup-texts '()))
(set! style-mapping (make-hash)))
(define/public (syncheck:arrows-visible?) (define/public (syncheck:arrows-visible?)
(or arrow-records cursor-pos cursor-text cursor-eles cursor-tooltip)) (or arrow-records cursor-pos cursor-text cursor-eles cursor-tooltip))
@ -504,7 +498,6 @@ If the namespace does not, they are colored the unbound color.
(when (update-latent-arrows #f #f) (when (update-latent-arrows #f #f)
(update-drawn-arrows)) (update-drawn-arrows))
(syncheck:clear-coloring) (syncheck:clear-coloring)
(set! style-mapping #f)
(invalidate-bitmap-cache))) (invalidate-bitmap-cache)))
(define/public (syncheck:clear-coloring) (define/public (syncheck:clear-coloring)
@ -514,19 +507,15 @@ If the namespace does not, they are colored the unbound color.
(set! cleanup-texts #f)) (set! cleanup-texts #f))
;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void
(define/public (syncheck:apply-style/remember txt start finish style mode) (define/public (syncheck:apply-style/remember txt start finish style)
(when (eq? mode syncheck-mode)
(add-to-cleanup/apply-style txt start finish style)) (add-to-cleanup/apply-style txt start finish style))
(when cleanup-texts
(hash-set! style-mapping mode (cons (list txt start finish style)
(hash-ref style-mapping mode '())))))
(define/public (syncheck:color-range source start finish style-name mode) (define/public (syncheck:color-range source start finish style-name)
(when (is-a? source text%) (when (is-a? source text%)
(define (apply-style/remember ed start finish style mode) (define (apply-style/remember ed start finish style)
(let ([outermost (find-outermost-editor ed)]) (let ([outermost (find-outermost-editor ed)])
(and (is-a? outermost syncheck-text<%>) (and (is-a? outermost syncheck-text<%>)
(send outermost syncheck:apply-style/remember ed start finish style mode)))) (send outermost syncheck:apply-style/remember ed start finish style))))
(define (find-outermost-editor ed) (define (find-outermost-editor ed)
(let loop ([ed ed]) (let loop ([ed ed])
@ -540,7 +529,7 @@ If the namespace does not, they are colored the unbound color.
(let ([style (send (send source get-style-list) (let ([style (send (send source get-style-list)
find-named-style find-named-style
style-name)]) style-name)])
(apply-style/remember source start finish style mode)))) (apply-style/remember source start finish style))))
;; add-to-cleanup/apply-style : (is-a?/c text%) number number style% symbol -> boolean ;; add-to-cleanup/apply-style : (is-a?/c text%) number number style% symbol -> boolean
(define/private (add-to-cleanup/apply-style txt start finish style) (define/private (add-to-cleanup/apply-style txt start finish style)
@ -1391,47 +1380,6 @@ If the namespace does not, they are colored the unbound color.
(send frame update-button-visibility/settings settings))) (send frame update-button-visibility/settings settings)))
(inner (void) after-set-next-settings settings)) (inner (void) after-set-next-settings settings))
(define syncheck-mode 'default-mode)
(define/public (set-syncheck-mode m)
(let ([old-mode syncheck-mode])
(set! syncheck-mode m)
(when style-mapping
(unless (eq? old-mode syncheck-mode)
(apply-syncheck-mode)))))
(define/public (get-syncheck-mode) (if style-mapping
syncheck-mode
#f))
(define/private (apply-syncheck-mode)
(let ([edit-sequences '()])
;; we need to reset the colors in every editor we can find, not just those that have new colors
(for ([(k v) (in-hash style-mapping)])
(for ((l (in-list v)))
(let-values ([(txt start finish style) (apply values l)])
(unless (memq txt edit-sequences)
(send txt begin-edit-sequence #f)
;; this little dance resets the
;; colors to their natural values
(begin
(cond
[(send txt is-frozen?)
(send txt thaw-colorer)]
[else
(send txt freeze-colorer)
(send txt thaw-colorer)])
(send txt freeze-colorer))
(set! edit-sequences (cons txt edit-sequences))))))
(for ((l (in-list (reverse (hash-ref style-mapping syncheck-mode '())))))
(let-values ([(txt start finish style) (apply values l)])
(add-to-cleanup/apply-style txt start finish style)))
(for ((txt (in-list edit-sequences)))
(send txt end-edit-sequence))))
(define/public (syncheck:find-source-object stx) (define/public (syncheck:find-source-object stx)
(cond (cond
[(not (syntax-source stx)) #f] [(not (syntax-source stx)) #f]
@ -1497,8 +1445,7 @@ If the namespace does not, they are colored the unbound color.
(when error-report-visible? (when error-report-visible?
(cond (cond
[(is-current-tab?) [(is-current-tab?)
(send (get-frame) hide-error-report) (send (get-frame) hide-error-report)]
(send (get-frame) update-menu-status this)]
[else [else
(set! error-report-visible? #f)]))) (set! error-report-visible? #f)])))
@ -1540,7 +1487,6 @@ If the namespace does not, they are colored the unbound color.
(show-error-report) (show-error-report)
(hide-error-report)) (hide-error-report))
(send report-error-canvas set-editor (send new-tab get-error-report-text)) (send report-error-canvas set-editor (send new-tab get-error-report-text))
(update-menu-status new-tab)
(update-button-visibility/tab new-tab)) (update-button-visibility/tab new-tab))
(define/private (update-button-visibility/tab tab) (define/private (update-button-visibility/tab tab)
@ -1669,13 +1615,9 @@ If the namespace does not, they are colored the unbound color.
(define/augment (enable-evaluation) (define/augment (enable-evaluation)
(send check-syntax-button enable #t) (send check-syntax-button enable #t)
(send mode-menu-item1 enable #t)
(send mode-menu-item2 enable #t)
(inner (void) enable-evaluation)) (inner (void) enable-evaluation))
(define/augment (disable-evaluation) (define/augment (disable-evaluation)
(send mode-menu-item1 enable #f)
(send mode-menu-item2 enable #f)
(send check-syntax-button enable #f) (send check-syntax-button enable #f)
(inner (void) disable-evaluation)) (inner (void) disable-evaluation))
@ -1757,54 +1699,10 @@ If the namespace does not, they are colored the unbound color.
(set! rest-panel r-root) (set! rest-panel r-root)
r-root)) r-root))
(define mode-menu-item1 #f)
(define mode-menu-item2 #f)
(define mode-menu-item3 #f)
(define/override (add-show-menu-items show-menu)
(define (start-checking mode)
(let* ([tab (get-current-tab)]
[defs (send tab get-defs)])
(preferences:set 'drracket:syncheck-mode mode)
(cond
[(send defs get-syncheck-mode)
(send defs set-syncheck-mode mode)
(update-menu-status tab)]
[else
(syncheck:button-callback #f mode)])))
(super add-show-menu-items show-menu)
(let ([p (new menu%
[parent show-menu]
[label cs-check-syntax-mode])])
(set! mode-menu-item1
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-syntax]
[callback (λ (a b) (start-checking 'default-mode))]))
(set! mode-menu-item2
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-my-obligations]
[callback (λ (a b) (start-checking 'my-obligations-mode))]))
(set! mode-menu-item3
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-client-obligations]
[callback (λ (a b) (start-checking 'client-obligations-mode))]))))
(define/public (update-menu-status tab)
(when mode-menu-item1
(let ([mode (send (send (get-current-tab) get-defs) get-syncheck-mode)])
(send mode-menu-item1 check (eq? mode 'default-mode))
(send mode-menu-item2 check (eq? mode 'my-obligations-mode))
(send mode-menu-item3 check (eq? mode 'client-obligations-mode)))))
(inherit open-status-line close-status-line update-status-line ensure-rep-hidden) (inherit open-status-line close-status-line update-status-line ensure-rep-hidden)
;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void) ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
;; this is the only function that has any code running on the user's thread ;; this is the only function that has any code running on the user's thread
(define/public (syncheck:button-callback [jump-to-id #f] (define/public (syncheck:button-callback [jump-to-id #f])
[mode (preferences:get 'drracket:syncheck-mode)])
(when (send check-syntax-button is-enabled?) (when (send check-syntax-button is-enabled?)
(open-status-line 'drracket:check-syntax:status) (open-status-line 'drracket:check-syntax:status)
(update-status-line 'drracket:check-syntax:status status-init) (update-status-line 'drracket:check-syntax:status status-init)
@ -1952,8 +1850,6 @@ If the namespace does not, they are colored the unbound color.
(λ () (λ ()
(parameterize ([current-annotations definitions-text]) (parameterize ([current-annotations definitions-text])
(expansion-completed)) (expansion-completed))
(send (send (get-current-tab) get-defs) set-syncheck-mode mode)
(update-menu-status (get-current-tab))
(send definitions-text syncheck:sort-bindings-table))) (send definitions-text syncheck:sort-bindings-table)))
(cleanup) (cleanup)
(custodian-shutdown-all user-custodian))))] (custodian-shutdown-all user-custodian))))]

2
collects/drracket/private/syncheck/intf.rkt
View File

@ -45,7 +45,7 @@
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void)) (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void))
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void)) (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void))
(define/public (syncheck:add-jump-to-definition text start end id filename) (void)) (define/public (syncheck:add-jump-to-definition text start end id filename) (void))
(define/public (syncheck:color-range source start finish style-name mode) (void)) (define/public (syncheck:color-range source start finish style-name) (void))
(super-new))) (super-new)))
(provide syncheck-text<%> (provide syncheck-text<%>

12
collects/drracket/private/syncheck/traversals.rkt
View File

@ -544,7 +544,7 @@
(define fin (+ start span)) (define fin (+ start span))
(send defs-text syncheck:add-background-color (send defs-text syncheck:add-background-color
source-editor start fin "firebrick"))) source-editor start fin "firebrick")))
(color stx unused-require-style-name 'default-mode))) (color stx unused-require-style-name)))
(hash-ref requires k (hash-ref requires k
(λ () (λ ()
(error 'syncheck/traversals.rkt "requires doesn't have a mapping for ~s" k))))))) (error 'syncheck/traversals.rkt "requires doesn't have a mapping for ~s" k)))))))
@ -667,10 +667,10 @@
#t)))]) #t)))])
(cond (cond
[top-bound? [top-bound?
(color var lexically-bound-variable-style-name 'default-mode)] (color var lexically-bound-variable-style-name)]
[else [else
(add-mouse-over var (format "~s is a free variable" (syntax-e var))) (add-mouse-over var (format "~s is a free variable" (syntax-e var)))
(color var free-variable-style-name 'default-mode)]) (color var free-variable-style-name)])
(connect-identifier var binders #f #f 0 user-namespace user-directory #t))) (connect-identifier var binders #f #f 0 user-namespace user-directory #t)))
;; color-variable : syntax phase-level identifier-mapping -> void ;; color-variable : syntax phase-level identifier-mapping -> void
@ -686,9 +686,9 @@
(cond (cond
[(get-ids varsets var) [(get-ids varsets var)
(add-mouse-over var (string-constant cs-set!d-variable)) (add-mouse-over var (string-constant cs-set!d-variable))
(color var set!d-variable-style-name 'default-mode)] (color var set!d-variable-style-name)]
[lexical? (color var lexically-bound-variable-style-name 'default-mode)] [lexical? (color var lexically-bound-variable-style-name)]
[(pair? b) (color var imported-variable-style-name 'default-mode)]))) [(pair? b) (color var imported-variable-style-name)])))
;; add-var : hash-table -> syntax -> void ;; add-var : hash-table -> syntax -> void
;; adds the variable to the hash table. ;; adds the variable to the hash table.