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
parent
c7810ba2ae
commit
39e4ac15e5
|
|
@ -232,7 +232,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; id : symbol -- the nominal-source-id from identifier-binding
|
||||
;; 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?)
|
||||
(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))
|
||||
(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))]
|
||||
;; this is a private field
|
||||
(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! arrow-records (make-hasheq))
|
||||
(set! bindings-table (make-hash))
|
||||
(set! cleanup-texts '()))
|
||||
(set! cleanup-texts '())
|
||||
(set! definition-targets (make-hash)))
|
||||
|
||||
(define/public (syncheck:arrows-visible?)
|
||||
(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)
|
||||
(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
|
||||
(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?)
|
||||
|
|
@ -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))))
|
||||
|
||||
;; 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
|
||||
(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
|
||||
(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)
|
||||
(add-sep)
|
||||
(let ([def-link (car def-links)])
|
||||
(make-object menu-item%
|
||||
(new menu-item%
|
||||
[label (if (def-link->tab/pos def-link)
|
||||
jump-to-definition
|
||||
menu
|
||||
(string-constant cs-open-defining-file))]
|
||||
[parent menu]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(jump-to-definition-callback def-link)))))
|
||||
(jump-to-definition-callback def-link))])))
|
||||
(unless (null? var-arrows)
|
||||
(add-sep)
|
||||
(make-object menu-item%
|
||||
|
|
@ -1472,12 +1487,39 @@ If the namespace does not, they are colored the unbound color.
|
|||
[else (loop (cdr arrows))])]))]))
|
||||
|
||||
;; 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)]
|
||||
[end-pos-left (list-ref to-arrow 1)]
|
||||
[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
|
||||
;; 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)))))))))
|
||||
|
||||
(define/private (jump-to-definition-callback def-link)
|
||||
(let* ([filename (def-link-filename def-link)]
|
||||
[id-from-def (def-link-id def-link)]
|
||||
[frame (fw:handler:edit-file filename)])
|
||||
(when (is-a? frame syncheck-frame<%>)
|
||||
(send frame syncheck:button-callback id-from-def))))
|
||||
(define go/f (def-link->tab/pos def-link))
|
||||
(cond
|
||||
[go/f (go/f)]
|
||||
[else (handler:edit-file (def-link-filename def-link))]))
|
||||
|
||||
;; 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)
|
||||
(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)]
|
||||
[`#(syncheck:add-background-color ,color ,start ,fin)
|
||||
(send defs-text syncheck:add-background-color defs-text color start fin)]
|
||||
[`#(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-jump-to-definition ,start ,end ,id ,filename ,submods)
|
||||
(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)
|
||||
(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)]
|
||||
[`#(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)
|
||||
(define other-side-dead? #f)
|
||||
(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)
|
||||
;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
|
||||
;; 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?)
|
||||
(open-status-line 'drracket:check-syntax:status)
|
||||
(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)
|
||||
(update-status-line 'drracket:check-syntax:status status-coloring-program)
|
||||
(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))))))
|
||||
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
|
||||
(close-status-line 'drracket:check-syntax:status)
|
||||
(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
|
||||
;; sets the current-directory based on the file saved in the definitions-text
|
||||
(define/private (set-directory definitions-text)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
syncheck:add-tail-arrow
|
||||
syncheck:add-mouse-over-status
|
||||
syncheck:add-jump-to-definition
|
||||
syncheck:add-definition-target
|
||||
syncheck:color-range
|
||||
|
||||
syncheck:add-rename-menu))
|
||||
|
|
@ -54,7 +55,8 @@
|
|||
(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-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))
|
||||
(super-new)))
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,10 @@
|
|||
;syncheck:get-bindings-table ;; test suite uses this one.
|
||||
syncheck:clear-error-message
|
||||
|
||||
syncheck:find-definition-target
|
||||
|
||||
jump-to
|
||||
|
||||
hide-error-report
|
||||
get-error-report-text
|
||||
get-error-report-visible?
|
||||
|
|
|
|||
|
|
@ -53,7 +53,8 @@
|
|||
(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-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-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?)
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@
|
|||
[tl-phase-to-requires (make-hash)]
|
||||
[tl-module-lang-requires (make-hash)]
|
||||
[expanded-expression
|
||||
(λ (sexp [visit-id void])
|
||||
(λ (sexp)
|
||||
(parameterize ([current-directory (or user-directory (current-directory))]
|
||||
[current-load-relative-directory user-directory])
|
||||
(let ([is-module? (syntax-case sexp (module)
|
||||
|
|
@ -79,7 +79,7 @@
|
|||
[require-for-templates (make-hash)]
|
||||
[require-for-labels (make-hash)])
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory visit-id
|
||||
user-namespace user-directory
|
||||
phase-to-binders
|
||||
phase-to-varrefs
|
||||
phase-to-varsets
|
||||
|
|
@ -102,7 +102,7 @@
|
|||
binding-inits))]
|
||||
[else
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory visit-id
|
||||
user-namespace user-directory
|
||||
tl-phase-to-binders
|
||||
tl-phase-to-varrefs
|
||||
tl-phase-to-varsets
|
||||
|
|
@ -133,12 +133,11 @@
|
|||
;; annotate-basic : syntax
|
||||
;; namespace
|
||||
;; string[directory]
|
||||
;; syntax[id]
|
||||
;; id-set (8 of them)
|
||||
;; hash-table[require-spec -> syntax] (three of them)
|
||||
;; -> void
|
||||
(define (annotate-basic stx-obj
|
||||
user-namespace user-directory visit-id
|
||||
user-namespace user-directory
|
||||
phase-to-binders
|
||||
phase-to-varrefs
|
||||
phase-to-varsets
|
||||
|
|
@ -148,11 +147,14 @@
|
|||
module-lang-requires
|
||||
phase-to-requires)
|
||||
|
||||
(let ([maybe-jump (λ (vars) (visit-id vars))])
|
||||
(let level+tail-loop ([stx-obj stx-obj]
|
||||
(let level+tail+mod-loop ([stx-obj stx-obj]
|
||||
[level 0]
|
||||
[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)
|
||||
(let ([child-src (find-source-editor stx-obj)]
|
||||
[child-pos (syntax-position stx-obj)]
|
||||
|
|
@ -168,9 +170,13 @@
|
|||
(values child-src child-pos)]
|
||||
[else
|
||||
(values tail-parent-src tail-parent-pos)])))
|
||||
(let* ([level-loop (λ (sexp level) (level+tail-loop sexp level #f #f))]
|
||||
[tail-loop (λ (sexp) (level+tail-loop sexp level next-tail-parent-src next-tail-parent-pos))]
|
||||
[loop (λ (sexp) (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+mod-loop sexp level next-tail-parent-src next-tail-parent-pos mods))]
|
||||
[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)]
|
||||
[varsets (lookup-phase-to-mapping phase-to-varsets level)]
|
||||
[binders (lookup-phase-to-mapping phase-to-binders level)]
|
||||
|
|
@ -306,13 +312,13 @@
|
|||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-binders (syntax vars) binders binding-inits #'b)
|
||||
(maybe-jump (syntax vars))
|
||||
(add-definition-target (syntax vars) mods)
|
||||
(loop (syntax b)))]
|
||||
[(define-syntaxes names exp)
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
(add-binders (syntax names) binders binding-inits #'exp)
|
||||
(maybe-jump (syntax names))
|
||||
(add-definition-target (syntax names) mods)
|
||||
(level-loop (syntax exp) (+ level 1)))]
|
||||
[(begin-for-syntax exp ...)
|
||||
(begin
|
||||
|
|
@ -324,7 +330,8 @@
|
|||
(hash-set! module-lang-requires (syntax lang) #t)
|
||||
(annotate-require-open user-namespace user-directory (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 ...))
|
||||
(begin
|
||||
(annotate-raw-keyword stx-obj varrefs)
|
||||
|
|
@ -333,7 +340,8 @@
|
|||
(annotate-require-open user-namespace user-directory (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:
|
||||
|
|
@ -403,7 +411,7 @@
|
|||
(syntax->datum sexp))
|
||||
(and (syntax? sexp)
|
||||
(syntax-source sexp)))
|
||||
(void))])))))
|
||||
(void))]))))
|
||||
|
||||
(define (hash-cons! ht k v)
|
||||
(hash-set! ht k (cons v (hash-ref ht k '()))))
|
||||
|
|
@ -597,12 +605,13 @@
|
|||
id
|
||||
(syntax->datum req-stx))
|
||||
(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
|
||||
(add-jump-to-definition
|
||||
var
|
||||
source-id
|
||||
filename)))
|
||||
filename
|
||||
submods)))
|
||||
(define raw-module-path (phaseless-spec->raw-module-path req-stx))
|
||||
(add-mouse-over var
|
||||
(format
|
||||
|
|
@ -645,8 +654,7 @@
|
|||
[_ stx]))
|
||||
|
||||
|
||||
;; get-module-req-path : binding number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
|
||||
;; argument is the result of identifier-binding or identifier-transformer-binding
|
||||
;; get-module-req-path : identifier number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
|
||||
(define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t])
|
||||
(define binding (identifier-binding var phase-level))
|
||||
(and (pair? binding)
|
||||
|
|
@ -781,7 +789,7 @@
|
|||
;; registers the range in the editor so that the
|
||||
;; popup menu in this area allows the programmer to jump
|
||||
;; 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)]
|
||||
[defs-text (current-annotations)])
|
||||
(when (and source
|
||||
|
|
@ -795,7 +803,8 @@
|
|||
pos-left
|
||||
pos-right
|
||||
id
|
||||
filename)))))
|
||||
filename
|
||||
submods)))))
|
||||
|
||||
;; annotate-require-open : namespace string -> (stx -> void)
|
||||
;; relies on current-module-name-resolver, which in turn depends on
|
||||
|
|
@ -810,7 +819,8 @@
|
|||
(when defs-text
|
||||
(define start (- (syntax-position require-spec) 1))
|
||||
(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-directory))
|
||||
(when file
|
||||
|
|
@ -823,16 +833,25 @@
|
|||
(parameterize ([current-namespace user-namespace]
|
||||
[current-directory (or user-directory (current-directory))]
|
||||
[current-load-relative-directory user-directory])
|
||||
(let* ([rkt-path/mod-path
|
||||
(define mpi
|
||||
(with-handlers ([exn:fail? (λ (x) #f)])
|
||||
(cond
|
||||
[(module-path-index? datum)
|
||||
(resolved-module-path-name
|
||||
(module-path-index-resolve datum))]
|
||||
(module-path-index-resolve datum)]
|
||||
[else
|
||||
(resolved-module-path-name
|
||||
((current-module-name-resolver) datum #f #f))]))]
|
||||
[rkt-path/f (and (path? rkt-path/mod-path) rkt-path/mod-path)])
|
||||
((current-module-name-resolver) datum #f #f)])))
|
||||
(define rkt-path/mod-path (and mpi (resolved-module-path-name mpi)))
|
||||
(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
|
||||
(unless (path? 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"))])
|
||||
(unless (file-exists? ss-path)
|
||||
(k rkt-path/f))
|
||||
ss-path))))))
|
||||
ss-path))))
|
||||
(values cleaned-up-path rkt-submods)))
|
||||
|
||||
;; possible-suffixes : (listof string)
|
||||
;; these are the suffixes that are checked for the reverse
|
||||
|
|
@ -941,6 +961,25 @@
|
|||
(add-init-exp binding-to-init stx init-exp))
|
||||
(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
|
||||
;; annotates keywords when they were never expanded. eg.
|
||||
;; if someone just types `(λ (x) x)' it has no 'origin
|
||||
|
|
|
|||
|
|
@ -2996,7 +2996,7 @@ module browser threading seems wrong.
|
|||
;; updates current-tab, definitions-text, and interactactions-text
|
||||
;; to be the nth tab. Also updates the GUI to show the new tab
|
||||
(inherit begin-container-sequence end-container-sequence)
|
||||
(define/private (change-to-tab tab)
|
||||
(define/public (change-to-tab tab)
|
||||
(unless (eq? current-tab tab)
|
||||
(let ([old-tab current-tab])
|
||||
(save-visible-tab-regions)
|
||||
|
|
@ -3179,17 +3179,15 @@ module browser threading seems wrong.
|
|||
(when tab
|
||||
(change-to-tab tab))))
|
||||
|
||||
(define/private (find-matching-tab filename)
|
||||
(let loop ([tabs tabs])
|
||||
(cond
|
||||
[(null? tabs) #f]
|
||||
[else
|
||||
(let* ([tab (car tabs)]
|
||||
[tab-filename (send (send tab get-defs) get-filename)])
|
||||
(if (and tab-filename
|
||||
(pathname-equal? filename tab-filename))
|
||||
tab
|
||||
(loop (cdr tabs))))])))
|
||||
(define/public (find-matching-tab filename)
|
||||
(define fn-path (if (string? filename)
|
||||
(string->path filename)
|
||||
filename))
|
||||
(for/or ([tab (in-list tabs)])
|
||||
(define tab-filename (send (send tab get-defs) get-filename))
|
||||
(and tab-filename
|
||||
(pathname-equal? fn-path tab-filename)
|
||||
tab)))
|
||||
|
||||
(define/override (editing-this-file? filename)
|
||||
(ormap (λ (tab)
|
||||
|
|
|
|||
|
|
@ -768,11 +768,21 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
|
|||
[start exact-nonnegative-integer?]
|
||||
[end exact-nonnegative-integer?]
|
||||
[id any/c]
|
||||
[filename path-string?])
|
||||
[filename path-string?]
|
||||
[submods (listof symbol?)])
|
||||
void?]{
|
||||
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)]
|
||||
[start exact-nonnegative-integer?]
|
||||
[finish exact-nonnegative-integer?]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(edit-menu:between-select-all-and-find)
|
||||
void?]{
|
||||
|
|
|
|||
|
|
@ -194,6 +194,7 @@ please adhere to these guidelines:
|
|||
(cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence")
|
||||
(cs-jump-to-binding "Jump to Binding Occurrence")
|
||||
(cs-jump-to-definition "Jump to Definition")
|
||||
(cs-open-defining-file "Open Defining File")
|
||||
(cs-error-message "Error Message")
|
||||
(cs-open-file "Open ~a")
|
||||
(cs-rename-var "Rename ~a")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user