bring 'jump to definition' more in line with online check syntax

That is, when right-clicking on an imported identifier, if the
file that has that identifier's definition is open and online
check syntax has completed, then offer a "jump to definition" menu
item that just jumps there with the already computed informtion.
If the file isn't open or online check syntax hasn't completed,
instead offer just to go to the file, without jumping to the definition

also
- things should generally work slightly better with submodules
- jumping to identifiers should do a better job with scrolling,
  specifically it should scroll so the jumped-to identifier is
  about 20% from the top of the window (unless it was already visible,
  in which case no scrolling should occur)
This commit is contained in:
Robby Findler 2013-03-05 08:53:53 -06:00
parent c7810ba2ae
commit 39e4ac15e5
9 changed files with 201 additions and 120 deletions

View File

@ -232,7 +232,7 @@ If the namespace does not, they are colored the unbound color.
;; id : symbol -- the nominal-source-id from identifier-binding ;; id : symbol -- the nominal-source-id from identifier-binding
;; filename : path ;; filename : path
(define-struct def-link (id filename) #:inspector (make-inspector)) (define-struct def-link (id filename submods) #:transparent)
(define (get-tacked-var-brush white-on-black?) (define (get-tacked-var-brush white-on-black?)
(if white-on-black? (if white-on-black?
@ -394,6 +394,11 @@ 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)
;; definition-targets : hash-table[(list symbol[id-name] (listof symbol[submodname]))
;; -o> (list text number number)]
(define definition-targets (make-hash))
;; bindings-table : hash-table[(list text number number) -o> (setof (list text number number))] ;; bindings-table : hash-table[(list text number number) -o> (setof (list text number number))]
;; this is a private field ;; this is a private field
(define bindings-table (make-hash)) (define bindings-table (make-hash))
@ -551,7 +556,8 @@ 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! definition-targets (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))
@ -643,6 +649,12 @@ If the namespace does not, they are colored the unbound color.
(λ (x y) (λ (x y)
(visit-docs-url))])))) (visit-docs-url))]))))
(define/public (syncheck:add-definition-target source start-pos end-pos id mods)
(hash-set! definition-targets (list id mods) (list source start-pos end-pos)))
;; syncheck:find-definition-target : sym (listof sym) -> (or/c (list/c text number number) #f)
(define/public (syncheck:find-definition-target id mods)
(hash-ref definition-targets (list id mods) #f))
;; no longer used, but must be here for backwards compatibility ;; no longer used, but must be here for backwards compatibility
(define/public (syncheck:add-rename-menu id to-be-renamed/poss name-dup?) (void)) (define/public (syncheck:add-rename-menu id to-be-renamed/poss name-dup?) (void))
(define/public (syncheck:add-id-set to-be-renamed/poss name-dup?) (define/public (syncheck:add-id-set to-be-renamed/poss name-dup?)
@ -787,9 +799,9 @@ If the namespace does not, they are colored the unbound color.
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f)))) (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))))
;; syncheck:add-jump-to-definition : text start end id filename -> void ;; syncheck:add-jump-to-definition : text start end id filename -> void
(define/public (syncheck:add-jump-to-definition text start end id filename) (define/public (syncheck:add-jump-to-definition text start end id filename submods)
(when arrow-records (when arrow-records
(add-to-range/key text start end (make-def-link id filename) #f #f))) (add-to-range/key text start end (make-def-link id filename submods) #f #f)))
;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
@ -1168,11 +1180,14 @@ If the namespace does not, they are colored the unbound color.
(unless (null? def-links) (unless (null? def-links)
(add-sep) (add-sep)
(let ([def-link (car def-links)]) (let ([def-link (car def-links)])
(make-object menu-item% (new menu-item%
[label (if (def-link->tab/pos def-link)
jump-to-definition jump-to-definition
menu (string-constant cs-open-defining-file))]
[parent menu]
[callback
(λ (item evt) (λ (item evt)
(jump-to-definition-callback def-link))))) (jump-to-definition-callback def-link))])))
(unless (null? var-arrows) (unless (null? var-arrows)
(add-sep) (add-sep)
(make-object menu-item% (make-object menu-item%
@ -1472,12 +1487,39 @@ If the namespace does not, they are colored the unbound color.
[else (loop (cdr arrows))])]))])) [else (loop (cdr arrows))])]))]))
;; jump-to : (list text number number) -> void ;; jump-to : (list text number number) -> void
(define/private (jump-to to-arrow) (define/public (jump-to to-arrow)
(let ([end-text (list-ref to-arrow 0)] (let ([end-text (list-ref to-arrow 0)]
[end-pos-left (list-ref to-arrow 1)] [end-pos-left (list-ref to-arrow 1)]
[end-pos-right (list-ref to-arrow 2)]) [end-pos-right (list-ref to-arrow 2)])
(send end-text set-position end-pos-left end-pos-right) (send end-text set-caret-owner #f 'global)
(send end-text set-caret-owner #f 'global))) (define admin (send end-text get-admin))
(when admin
(define vxb (box 0.0))
(define vyb (box 0.0))
(define vwb (box 0.0))
(define vhb (box 0.0))
(define pxb (box 0.0))
(define pyb (box 0.0))
(send admin get-view vxb vyb vwb vhb)
(send end-text position-location end-pos-left pxb pyb #t #f #t)
(define vx (unbox vxb))
(define vy (unbox vyb))
(define vw (unbox vwb))
(define vh (unbox vhb))
(define px (unbox pxb))
(define py (unbox pyb))
(unless (and (<= vx px (+ vx vw))
(<= vy py (+ vy vh)))
(send end-text scroll-editor-to
(max 0 (- px (* .2 vw)))
(max 0 (- py (* .2 vh)))
vw vh
#t
'none)))
;; set-position after attempting to scroll, or
;; else set-position's scrolling will cause the
;; 'unless' test above to skip the call to scroll-editor-to
(send end-text set-position end-pos-left end-pos-right)))
;; jump-to-binding-callback : (listof arrow) -> void ;; jump-to-binding-callback : (listof arrow) -> void
;; callback for the jump popup menu item ;; callback for the jump popup menu item
@ -1501,11 +1543,28 @@ If the namespace does not, they are colored the unbound color.
(jump-to-definition-callback (car vec-ents))))))))) (jump-to-definition-callback (car vec-ents)))))))))
(define/private (jump-to-definition-callback def-link) (define/private (jump-to-definition-callback def-link)
(let* ([filename (def-link-filename def-link)] (define go/f (def-link->tab/pos def-link))
[id-from-def (def-link-id def-link)] (cond
[frame (fw:handler:edit-file filename)]) [go/f (go/f)]
(when (is-a? frame syncheck-frame<%>) [else (handler:edit-file (def-link-filename def-link))]))
(send frame syncheck:button-callback id-from-def))))
;; def-link->tab/pos : def-link -> (or/c #f (-> void?))
;; if the result is a function, invoking it will open the file
;; in the def-link and jump to the appropriate position in the file
(define/private (def-link->tab/pos a-def-link)
(match-define (def-link id filename submods) a-def-link)
(define tab
(for/or ([frame (in-list (send (group:get-the-frame-group) get-frames))])
(send frame find-matching-tab filename)))
(define dt
(and tab
(send (send tab get-defs) syncheck:find-definition-target id submods)))
(and dt
(λ ()
(define frame (send tab get-frame))
(send frame change-to-tab tab)
(send frame show #t)
(send (send tab get-defs) jump-to dt))))
(define/augment (after-set-next-settings settings) (define/augment (after-set-next-settings settings)
(let ([frame (get-top-level-window)]) (let ([frame (get-top-level-window)])
@ -1742,12 +1801,14 @@ If the namespace does not, they are colored the unbound color.
(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 ,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 ,start ,end ,id ,filename) [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename ,submods)
(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 submods)]
[`#(syncheck:add-require-open-menu ,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 ,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-definition-target ,start-pos ,end-pos ,id ,mods)
(send defs-text syncheck:add-definition-target defs-text start-pos end-pos id mods)]
[`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) [`#(syncheck:add-id-set ,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)
@ -1858,7 +1919,7 @@ If the namespace does not, they are colored the unbound color.
(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)
(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)
@ -2022,54 +2083,12 @@ If the namespace does not, they are colored the unbound color.
(open-status-line 'drracket:check-syntax:status) (open-status-line 'drracket:check-syntax:status)
(update-status-line 'drracket:check-syntax:status status-coloring-program) (update-status-line 'drracket:check-syntax:status status-coloring-program)
(parameterize ([current-annotations definitions-text]) (parameterize ([current-annotations definitions-text])
(expanded-expression sexp (if jump-to-id (make-visit-id jump-to-id) void))) (expanded-expression sexp))
(close-status-line 'drracket:check-syntax:status)))))) (close-status-line 'drracket:check-syntax:status))))))
(update-status-line 'drracket:check-syntax:status status-expanding-expression) (update-status-line 'drracket:check-syntax:status status-expanding-expression)
(close-status-line 'drracket:check-syntax:status) (close-status-line 'drracket:check-syntax:status)
(loop)]))))))) (loop)])))))))
(define (make-visit-id jump-to-id)
(λ (vars)
(when jump-to-id
(for ([id (in-list (syntax->list vars))])
(let ([binding (identifier-binding id 0)])
(when (pair? binding)
(let ([nominal-source-id (list-ref binding 3)])
(when (eq? nominal-source-id jump-to-id)
(let ([stx id])
(let ([src (find-source-editor stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)])
(when (and (is-a? src text%)
pos
span)
(send src begin-edit-sequence)
;; try to scroll so stx's location is
;; near the top of the visible region
(let ([admin (send src get-admin)])
(when admin
(let ([wb (box 0.0)]
[hb (box 0.0)]
[xb (box 0.0)]
[yb (box 0.0)])
(send admin get-view #f #f wb hb)
(send src position-location (- pos 1) xb yb #t #f #t)
(let ([w (unbox wb)]
[h (unbox hb)]
[x (unbox xb)]
[y (unbox yb)])
(send src scroll-editor-to
(max 0 (- x (* .1 w)))
(max 0 (- y (* .1 h)))
w h
#t
'none)))))
(send src set-position (- pos 1) (+ pos span -1))
(send src end-edit-sequence))))))))))))
;; set-directory : text -> void ;; set-directory : text -> void
;; sets the current-directory based on the file saved in the definitions-text ;; sets the current-directory based on the file saved in the definitions-text
(define/private (set-directory definitions-text) (define/private (set-directory definitions-text)

View File

@ -13,6 +13,7 @@
syncheck:add-tail-arrow syncheck:add-tail-arrow
syncheck:add-mouse-over-status syncheck:add-mouse-over-status
syncheck:add-jump-to-definition syncheck:add-jump-to-definition
syncheck:add-definition-target
syncheck:color-range syncheck:color-range
syncheck:add-rename-menu)) syncheck:add-rename-menu))
@ -54,7 +55,8 @@
(void)) (void))
(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 submods) (void))
(define/public (syncheck:add-definition-target source pos-left pos-right id mods) (void))
(define/public (syncheck:color-range source start finish style-name) (void)) (define/public (syncheck:color-range source start finish style-name) (void))
(super-new))) (super-new)))

View File

@ -30,6 +30,10 @@
;syncheck:get-bindings-table ;; test suite uses this one. ;syncheck:get-bindings-table ;; test suite uses this one.
syncheck:clear-error-message syncheck:clear-error-message
syncheck:find-definition-target
jump-to
hide-error-report hide-error-report
get-error-report-text get-error-report-text
get-error-report-visible? get-error-report-visible?

View File

@ -53,7 +53,8 @@
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos) (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-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin) (log syncheck:add-background-color _text color start fin)
(log syncheck:add-jump-to-definition _text start end id filename) (log syncheck:add-jump-to-definition _text start end id filename submods)
(log syncheck:add-definition-target _text start-pos end-pos id mods)
(log syncheck:add-require-open-menu _text start-pos end-pos file) (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) (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
(define/override (syncheck:add-id-set to-be-renamed/poss dup-name?) (define/override (syncheck:add-id-set to-be-renamed/poss dup-name?)

View File

@ -58,7 +58,7 @@
[tl-phase-to-requires (make-hash)] [tl-phase-to-requires (make-hash)]
[tl-module-lang-requires (make-hash)] [tl-module-lang-requires (make-hash)]
[expanded-expression [expanded-expression
(λ (sexp [visit-id void]) (λ (sexp)
(parameterize ([current-directory (or user-directory (current-directory))] (parameterize ([current-directory (or user-directory (current-directory))]
[current-load-relative-directory user-directory]) [current-load-relative-directory user-directory])
(let ([is-module? (syntax-case sexp (module) (let ([is-module? (syntax-case sexp (module)
@ -79,7 +79,7 @@
[require-for-templates (make-hash)] [require-for-templates (make-hash)]
[require-for-labels (make-hash)]) [require-for-labels (make-hash)])
(annotate-basic sexp (annotate-basic sexp
user-namespace user-directory visit-id user-namespace user-directory
phase-to-binders phase-to-binders
phase-to-varrefs phase-to-varrefs
phase-to-varsets phase-to-varsets
@ -102,7 +102,7 @@
binding-inits))] binding-inits))]
[else [else
(annotate-basic sexp (annotate-basic sexp
user-namespace user-directory visit-id user-namespace user-directory
tl-phase-to-binders tl-phase-to-binders
tl-phase-to-varrefs tl-phase-to-varrefs
tl-phase-to-varsets tl-phase-to-varsets
@ -133,12 +133,11 @@
;; annotate-basic : syntax ;; annotate-basic : syntax
;; namespace ;; namespace
;; string[directory] ;; string[directory]
;; syntax[id]
;; id-set (8 of them) ;; id-set (8 of them)
;; hash-table[require-spec -> syntax] (three of them) ;; hash-table[require-spec -> syntax] (three of them)
;; -> void ;; -> void
(define (annotate-basic stx-obj (define (annotate-basic stx-obj
user-namespace user-directory visit-id user-namespace user-directory
phase-to-binders phase-to-binders
phase-to-varrefs phase-to-varrefs
phase-to-varsets phase-to-varsets
@ -148,11 +147,14 @@
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires)
(let ([maybe-jump (λ (vars) (visit-id vars))]) (let level+tail+mod-loop ([stx-obj stx-obj]
(let level+tail-loop ([stx-obj stx-obj]
[level 0] [level 0]
[tail-parent-src #f] [tail-parent-src #f]
[tail-parent-pos #f]) [tail-parent-pos #f]
;; mods: (or/f #f ; => outside a module
;; '() ; => inside the main module in this file
;; '(name names ...) ; => inside some submodules named by name & names
[mods #f])
(define-values (next-tail-parent-src next-tail-parent-pos) (define-values (next-tail-parent-src next-tail-parent-pos)
(let ([child-src (find-source-editor stx-obj)] (let ([child-src (find-source-editor stx-obj)]
[child-pos (syntax-position stx-obj)] [child-pos (syntax-position stx-obj)]
@ -168,9 +170,13 @@
(values child-src child-pos)] (values child-src child-pos)]
[else [else
(values tail-parent-src tail-parent-pos)]))) (values tail-parent-src tail-parent-pos)])))
(let* ([level-loop (λ (sexp level) (level+tail-loop sexp level #f #f))] (let* ([level-loop (λ (sexp level) (level+tail+mod-loop sexp level #f #f mods))]
[tail-loop (λ (sexp) (level+tail-loop sexp level next-tail-parent-src next-tail-parent-pos))] [tail-loop (λ (sexp) (level+tail+mod-loop sexp level next-tail-parent-src next-tail-parent-pos mods))]
[loop (λ (sexp) (level+tail-loop sexp level #f #f))] [mod-loop (λ (sexp mod) (level+tail+mod-loop sexp level #f #f
(if mods
(cons mod mods)
'())))]
[loop (λ (sexp) (level+tail+mod-loop sexp level #f #f mods))]
[varrefs (lookup-phase-to-mapping phase-to-varrefs level)] [varrefs (lookup-phase-to-mapping phase-to-varrefs level)]
[varsets (lookup-phase-to-mapping phase-to-varsets level)] [varsets (lookup-phase-to-mapping phase-to-varsets level)]
[binders (lookup-phase-to-mapping phase-to-binders level)] [binders (lookup-phase-to-mapping phase-to-binders level)]
@ -306,13 +312,13 @@
(begin (begin
(annotate-raw-keyword stx-obj varrefs) (annotate-raw-keyword stx-obj varrefs)
(add-binders (syntax vars) binders binding-inits #'b) (add-binders (syntax vars) binders binding-inits #'b)
(maybe-jump (syntax vars)) (add-definition-target (syntax vars) mods)
(loop (syntax b)))] (loop (syntax b)))]
[(define-syntaxes names exp) [(define-syntaxes names exp)
(begin (begin
(annotate-raw-keyword stx-obj varrefs) (annotate-raw-keyword stx-obj varrefs)
(add-binders (syntax names) binders binding-inits #'exp) (add-binders (syntax names) binders binding-inits #'exp)
(maybe-jump (syntax names)) (add-definition-target (syntax names) mods)
(level-loop (syntax exp) (+ level 1)))] (level-loop (syntax exp) (+ level 1)))]
[(begin-for-syntax exp ...) [(begin-for-syntax exp ...)
(begin (begin
@ -324,7 +330,8 @@
(hash-set! module-lang-requires (syntax lang) #t) (hash-set! module-lang-requires (syntax lang) #t)
(annotate-require-open user-namespace user-directory (syntax lang)) (annotate-require-open user-namespace user-directory (syntax lang))
(hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)) (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang))
(for-each loop (syntax->list (syntax (bodies ...)))))] (for ([body (in-list (syntax->list (syntax (bodies ...))))])
(mod-loop body (syntax-e #'m-name))))]
[(module* m-name lang (#%plain-module-begin bodies ...)) [(module* m-name lang (#%plain-module-begin bodies ...))
(begin (begin
(annotate-raw-keyword stx-obj varrefs) (annotate-raw-keyword stx-obj varrefs)
@ -333,7 +340,8 @@
(annotate-require-open user-namespace user-directory (syntax lang)) (annotate-require-open user-namespace user-directory (syntax lang))
(hash-cons! requires (syntax->datum (syntax lang)) (syntax lang))) (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)))
(for-each loop (syntax->list (syntax (bodies ...)))))] (for ([body (in-list (syntax->list (syntax (bodies ...))))])
(mod-loop body (syntax-e #'m-name))))]
; top level or module top level only: ; top level or module top level only:
@ -403,7 +411,7 @@
(syntax->datum sexp)) (syntax->datum sexp))
(and (syntax? sexp) (and (syntax? sexp)
(syntax-source sexp))) (syntax-source sexp)))
(void))]))))) (void))]))))
(define (hash-cons! ht k v) (define (hash-cons! ht k v)
(hash-set! ht k (cons v (hash-ref ht k '())))) (hash-set! ht k (cons v (hash-ref ht k '()))))
@ -597,12 +605,13 @@
id id
(syntax->datum req-stx)) (syntax->datum req-stx))
(when id (when id
(define filename (get-require-filename source-req-path user-namespace user-directory)) (define-values (filename submods) (get-require-filename source-req-path user-namespace user-directory))
(when filename (when filename
(add-jump-to-definition (add-jump-to-definition
var var
source-id source-id
filename))) filename
submods)))
(define raw-module-path (phaseless-spec->raw-module-path req-stx)) (define raw-module-path (phaseless-spec->raw-module-path req-stx))
(add-mouse-over var (add-mouse-over var
(format (format
@ -645,8 +654,7 @@
[_ stx])) [_ stx]))
;; get-module-req-path : binding number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path)) ;; get-module-req-path : identifier number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
;; argument is the result of identifier-binding or identifier-transformer-binding
(define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t]) (define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t])
(define binding (identifier-binding var phase-level)) (define binding (identifier-binding var phase-level))
(and (pair? binding) (and (pair? binding)
@ -781,7 +789,7 @@
;; registers the range in the editor so that the ;; registers the range in the editor so that the
;; popup menu in this area allows the programmer to jump ;; popup menu in this area allows the programmer to jump
;; to the definition of the id. ;; to the definition of the id.
(define (add-jump-to-definition stx id filename) (define (add-jump-to-definition stx id filename submods)
(let ([source (find-source-editor stx)] (let ([source (find-source-editor stx)]
[defs-text (current-annotations)]) [defs-text (current-annotations)])
(when (and source (when (and source
@ -795,7 +803,8 @@
pos-left pos-left
pos-right pos-right
id id
filename))))) filename
submods)))))
;; annotate-require-open : namespace string -> (stx -> void) ;; annotate-require-open : namespace string -> (stx -> void)
;; relies on current-module-name-resolver, which in turn depends on ;; relies on current-module-name-resolver, which in turn depends on
@ -810,7 +819,8 @@
(when defs-text (when defs-text
(define start (- (syntax-position require-spec) 1)) (define start (- (syntax-position require-spec) 1))
(define end (+ start (syntax-span require-spec))) (define end (+ start (syntax-span require-spec)))
(define file (get-require-filename (syntax->datum require-spec) (define-values (file submods)
(get-require-filename (syntax->datum require-spec)
user-namespace user-namespace
user-directory)) user-directory))
(when file (when file
@ -823,16 +833,25 @@
(parameterize ([current-namespace user-namespace] (parameterize ([current-namespace user-namespace]
[current-directory (or user-directory (current-directory))] [current-directory (or user-directory (current-directory))]
[current-load-relative-directory user-directory]) [current-load-relative-directory user-directory])
(let* ([rkt-path/mod-path (define mpi
(with-handlers ([exn:fail? (λ (x) #f)]) (with-handlers ([exn:fail? (λ (x) #f)])
(cond (cond
[(module-path-index? datum) [(module-path-index? datum)
(resolved-module-path-name (module-path-index-resolve datum)]
(module-path-index-resolve datum))]
[else [else
(resolved-module-path-name ((current-module-name-resolver) datum #f #f)])))
((current-module-name-resolver) datum #f #f))]))] (define rkt-path/mod-path (and mpi (resolved-module-path-name mpi)))
[rkt-path/f (and (path? rkt-path/mod-path) rkt-path/mod-path)]) (define rkt-path/f (cond
[(path? rkt-path/mod-path) rkt-path/mod-path]
[(and (pair? rkt-path/mod-path)
(path? (car rkt-path/mod-path)))
(car rkt-path/mod-path)]
[else #f]))
(define rkt-submods (cond
[(not rkt-path/mod-path) #f]
[(or (symbol? rkt-path/mod-path) (path? rkt-path/mod-path)) '()]
[(pair? rkt-path/mod-path) (cdr rkt-path/mod-path)]))
(define cleaned-up-path
(let/ec k (let/ec k
(unless (path? rkt-path/f) (k rkt-path/f)) (unless (path? rkt-path/f) (k rkt-path/f))
(when (file-exists? rkt-path/f) (k rkt-path/f)) (when (file-exists? rkt-path/f) (k rkt-path/f))
@ -844,7 +863,8 @@
(let ([ss-path (bytes->path (bytes-append (subbytes bts 0 (- len 4)) #".ss"))]) (let ([ss-path (bytes->path (bytes-append (subbytes bts 0 (- len 4)) #".ss"))])
(unless (file-exists? ss-path) (unless (file-exists? ss-path)
(k rkt-path/f)) (k rkt-path/f))
ss-path)))))) ss-path))))
(values cleaned-up-path rkt-submods)))
;; possible-suffixes : (listof string) ;; possible-suffixes : (listof string)
;; these are the suffixes that are checked for the reverse ;; these are the suffixes that are checked for the reverse
@ -941,6 +961,25 @@
(add-init-exp binding-to-init stx init-exp)) (add-init-exp binding-to-init stx init-exp))
(add-id id-set stx)])))) (add-id id-set stx)]))))
;; add-definition-target : syntax[(sequence of identifiers)] (listof symbol) -> void
(define (add-definition-target stx mods)
(when mods
(define defs-text (current-annotations))
(for ([id (in-list (syntax->list stx))])
(define source (syntax-source id))
(when (and source
defs-text
(syntax-position id)
(syntax-span id))
(let* ([pos-left (- (syntax-position id) 1)]
[pos-right (+ pos-left (syntax-span id))])
(send defs-text syncheck:add-definition-target
source
pos-left
pos-right
(syntax-e id)
mods))))))
;; annotate-raw-keyword : syntax id-map -> void ;; annotate-raw-keyword : syntax id-map -> void
;; annotates keywords when they were never expanded. eg. ;; annotates keywords when they were never expanded. eg.
;; if someone just types `(λ (x) x)' it has no 'origin ;; if someone just types `(λ (x) x)' it has no 'origin

View File

@ -2996,7 +2996,7 @@ module browser threading seems wrong.
;; updates current-tab, definitions-text, and interactactions-text ;; updates current-tab, definitions-text, and interactactions-text
;; to be the nth tab. Also updates the GUI to show the new tab ;; to be the nth tab. Also updates the GUI to show the new tab
(inherit begin-container-sequence end-container-sequence) (inherit begin-container-sequence end-container-sequence)
(define/private (change-to-tab tab) (define/public (change-to-tab tab)
(unless (eq? current-tab tab) (unless (eq? current-tab tab)
(let ([old-tab current-tab]) (let ([old-tab current-tab])
(save-visible-tab-regions) (save-visible-tab-regions)
@ -3179,17 +3179,15 @@ module browser threading seems wrong.
(when tab (when tab
(change-to-tab tab)))) (change-to-tab tab))))
(define/private (find-matching-tab filename) (define/public (find-matching-tab filename)
(let loop ([tabs tabs]) (define fn-path (if (string? filename)
(cond (string->path filename)
[(null? tabs) #f] filename))
[else (for/or ([tab (in-list tabs)])
(let* ([tab (car tabs)] (define tab-filename (send (send tab get-defs) get-filename))
[tab-filename (send (send tab get-defs) get-filename)]) (and tab-filename
(if (and tab-filename (pathname-equal? fn-path tab-filename)
(pathname-equal? filename tab-filename)) tab)))
tab
(loop (cdr tabs))))])))
(define/override (editing-this-file? filename) (define/override (editing-this-file? filename)
(ormap (λ (tab) (ormap (λ (tab)

View File

@ -768,11 +768,21 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?] [end exact-nonnegative-integer?]
[id any/c] [id any/c]
[filename path-string?]) [filename path-string?]
[submods (listof symbol?)])
void?]{ void?]{
Called to indicate that there is some identifier at the given location (named @racket[id]) that Called to indicate that there is some identifier at the given location (named @racket[id]) that
is defined in the file @racket[filename]. is defined in the @racket[submods] of the file @racket[filename] (where an empty list in @racket[submods]
means that the identifier is defined at the top-level module).
} }
@defmethod[(syncheck:add-definition-target [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[finish exact-nonnegative-integer?]
[style-name any/c])]{
}
@defmethod[(syncheck:color-range [source-obj (not/c #f)] @defmethod[(syncheck:color-range [source-obj (not/c #f)]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[finish exact-nonnegative-integer?] [finish exact-nonnegative-integer?]

View File

@ -283,6 +283,13 @@ safe to call this at anytime, however.
} }
@defmethod[(find-matching-tab [p path-string?]) (or/c (is-a?/c drracket:unit:tab%) #f)]{
Returns the tab that is currently editing @racket[p], if there is one
in this frame. Returns @racket[#f] otherwise.
}
@defmethod[(change-to-tab [tab (is-a?/c drracket:unit:tab%)]) void?]{
Makes @racket[tab] visible in this frame.
}
@defmethod[#:mode override @defmethod[#:mode override
(edit-menu:between-select-all-and-find) (edit-menu:between-select-all-and-find)
void?]{ void?]{

View File

@ -194,6 +194,7 @@ please adhere to these guidelines:
(cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence") (cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence")
(cs-jump-to-binding "Jump to Binding Occurrence") (cs-jump-to-binding "Jump to Binding Occurrence")
(cs-jump-to-definition "Jump to Definition") (cs-jump-to-definition "Jump to Definition")
(cs-open-defining-file "Open Defining File")
(cs-error-message "Error Message") (cs-error-message "Error Message")
(cs-open-file "Open ~a") (cs-open-file "Open ~a")
(cs-rename-var "Rename ~a") (cs-rename-var "Rename ~a")