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

streamline the objects that are sent across the channel from

Browse Source 
the expansion place to the main drracket place during
online check syntax
This commit is contained in:
Robby Findler 2012-10-31 16:52:01 -05:00
parent b9a0eaf5da
commit e2d74f2cf3
2 changed files with 35 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1606,26 +1606,26 @@ If the namespace does not, they are colored the unbound color.
;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; using 'defs-text' all the time is wrong in the case of embedded editors,
;; but they already don't work and we've arranged for them to not appear here .... ;; but they already don't work and we've arranged for them to not appear here ....
(match x (match x
[`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right
,end-text ,end-pos-left ,end-pos-right ,end-pos-left ,end-pos-right
,actual? ,level) ,actual? ,level)
(send defs-text syncheck:add-arrow (send defs-text syncheck:add-arrow
defs-text start-pos-left start-pos-right defs-text start-pos-left start-pos-right
defs-text end-pos-left end-pos-right defs-text end-pos-left end-pos-right
actual? level)] actual? level)]
[`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos) [`#(syncheck:add-tail-arrow ,from-pos ,to-pos)
(send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)]
[`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str) [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str)
(send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)] (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)]
[`(syncheck:add-background-color ,text ,color ,start ,fin) [`#(syncheck:add-background-color ,color ,start ,fin)
(send defs-text syncheck:add-background-color defs-text color start fin)] (send defs-text syncheck:add-background-color defs-text color start fin)]
[`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename) [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename)
(send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)]
[`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file)
(send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
[`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
(send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)]
[`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
(define other-side-dead? #f) (define other-side-dead? #f)
(define (name-dup? name) (define (name-dup? name)
(cond (cond
@ -1643,7 +1643,7 @@ If the namespace does not, they are colored the unbound color.
#f])])) #f])]))
(define to-be-renamed/poss/fixed (define to-be-renamed/poss/fixed
(for/list ([lst (in-list to-be-renamed/poss)]) (for/list ([lst (in-list to-be-renamed/poss)])
(list defs-text (list-ref lst 1) (list-ref lst 2)))) (list defs-text (list-ref lst 0) (list-ref lst 1))))
(send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed
name-dup?)])) name-dup?)]))

38
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/place racket/place
(for-syntax racket/base)
"../../private/eval-helpers.rkt" "../../private/eval-helpers.rkt"
"traversals.rkt" "traversals.rkt"
"local-member-names.rkt" "local-member-names.rkt"
@ -34,26 +35,35 @@
(define/override (syncheck:find-source-object stx) (define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx)) (and (equal? src (syntax-source stx))
src)) src))
(define-syntax-rule
(log name) ;; send over the non _ variables in the message to the main drracket place
(define/override (name . args) (define-syntax (log stx)
(set! trace (cons (cons 'name args) trace)))) (syntax-case stx ()
[(_ name args ...)
(with-syntax ([(wanted-args ...)
(filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x)))))
(syntax->list #'(args ...)))])
#'(define/override (name args ...)
(add-to-trace (vector 'name wanted-args ...))))]))
; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up (log syncheck:add-arrow
(log syncheck:add-mouse-over-status) _start-text start-pos-left start-pos-right
(log syncheck:add-arrow) _end-text end-pos-left end-pos-right
(log syncheck:add-tail-arrow) actual? level)
(log syncheck:add-background-color) (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-require-open-menu) (log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-docs-menu) (log syncheck:add-background-color _text color start fin)
(log syncheck:add-jump-to-definition) (log syncheck:add-jump-to-definition _text start end id filename)
(log syncheck:add-require-open-menu _text start-pos end-pos file)
(log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
(define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?) (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
(define id (hash-count table)) (define id (hash-count table))
(hash-set! table id dup-name?) (hash-set! table id dup-name?)
(set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id) (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
trace)))
(define/public (get-trace) (reverse trace)) (define/public (get-trace) (reverse trace))
(define/private (add-to-trace thing)
(set! trace (cons thing trace)))
(super-new))) (super-new)))
(define (go expanded path the-source orig-cust) (define (go expanded path the-source orig-cust)