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,
;; but they already don't work and we've arranged for them to not appear here ....
(match x
[`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right
,end-text ,end-pos-left ,end-pos-right
,actual? ,level)
[`#(syncheck:add-arrow ,start-pos-left ,start-pos-right
,end-pos-left ,end-pos-right
,actual? ,level)
(send defs-text syncheck:add-arrow
defs-text start-pos-left start-pos-right
defs-text end-pos-left end-pos-right
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)]
[`(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)]
[`(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)]
[`(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)]
[`(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)]
[`(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)]
[`(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 (name-dup? name)
(cond
@ -1643,7 +1643,7 @@ If the namespace does not, they are colored the unbound color.
#f])]))
(define to-be-renamed/poss/fixed
(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
name-dup?)]))

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
racket/place
(for-syntax racket/base)
"../../private/eval-helpers.rkt"
"traversals.rkt"
"local-member-names.rkt"
@ -34,26 +35,35 @@
(define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx))
src))
(define-syntax-rule
(log name)
(define/override (name . args)
(set! trace (cons (cons 'name args) trace))))
;; send over the non _ variables in the message to the main drracket place
(define-syntax (log stx)
(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-mouse-over-status)
(log syncheck:add-arrow)
(log syncheck:add-tail-arrow)
(log syncheck:add-background-color)
(log syncheck:add-require-open-menu)
(log syncheck:add-docs-menu)
(log syncheck:add-jump-to-definition)
(log syncheck:add-arrow
_start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right
actual? level)
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin)
(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 id (hash-count table))
(hash-set! table id dup-name?)
(set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id)
trace)))
(add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
(define/public (get-trace) (reverse trace))
(define/private (add-to-trace thing)
(set! trace (cons thing trace)))
(super-new)))
(define (go expanded path the-source orig-cust)