diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 897bc7e5d1..abcb575df8 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -339,7 +339,7 @@ (let loop ([spec spec] [level level]) (define (add-to-level n) (and n level (+ n level))) - (syntax-case* spec (for-meta for-syntax for-template for-label just-meta) sym-eq? + (syntax-case* spec (for-meta for-syntax for-template for-label just-meta) symbolic-compare? [(for-meta phase specs ...) (for ([spec (in-list (syntax->list #'(specs ...)))]) (loop spec (add-to-level (syntax-e #'phase))))] @@ -363,21 +363,13 @@ (define h (make-hash)) (hash-set! phase-to-requires level h) h))) - (define raw-module-path - (syntax-case* stx (only prefix all-expect prefix-all-except rename) sym-eq? - [(only raw-module-path id ...) #'raw-module-path] - [(prefix prefix-id raw-module-path) #'raw-module-path] - [(all-except raw-module-path id ...) #'raw-module-path] - [(prefix-all-except prefix-id raw-module-path id ...) #'raw-module-path] - [(rename raw-module-path local-id exported-id) #'raw-module-path] - [_ stx])) + (define raw-module-path (phaseless-spec->raw-module-path stx)) (annotate-require-open user-namespace user-directory raw-module-path) (when (syntax-original? raw-module-path) (define key (syntax->datum raw-module-path)) (hash-set! require-ht key (cons stx (hash-ref require-ht key '()))))) - (define (sym-eq? a b) (eq? (syntax-e a) (syntax-e b))) (for ([spec (in-list (syntax->list #'(raw-require-specs ...)))]) (handle-raw-require-spec spec)))] @@ -574,45 +566,50 @@ (define (connect-identifier var all-binders unused/phases phase-to-requires phase-level user-namespace user-directory actual? connections) - (let ([binders (get-ids all-binders var)]) - (when binders - (for ([x (in-list binders)]) - (connect-syntaxes x var actual? (id-level phase-level x) connections))) + (define binders (get-ids all-binders var)) + (when binders + (for ([x (in-list binders)]) + (connect-syntaxes x var actual? (id-level phase-level x) connections))) - (when (and unused/phases phase-to-requires) - (let ([req-path/pr (get-module-req-path var phase-level)] - [source-req-path/pr (get-module-req-path var phase-level #:nominal? #f)]) - (when (and req-path/pr source-req-path/pr) - (let* ([req-path (list-ref req-path/pr 0)] - [id (list-ref req-path/pr 1)] - [source-req-path (list-ref source-req-path/pr 3)] - [source-id (list-ref source-req-path/pr 1)] - [req-phase-level (list-ref req-path/pr 2)] - [unused (hash-ref! unused/phases req-phase-level (λ () (make-hash)))] - [requires (hash-ref! phase-to-requires req-phase-level (λ () (make-hash)))] - [req-stxes (hash-ref requires req-path (λ () #f))]) - (when req-stxes - (hash-remove! unused req-path) - (for ([req-stx (in-list req-stxes)]) - (when (id/require-match? (syntax->datum var) - id - (syntax->datum req-stx)) - (when id - (define filename (get-require-filename source-req-path user-namespace user-directory)) - (when filename - (add-jump-to-definition - var - source-id - filename))) - (add-mouse-over var - (format - (string-constant cs-mouse-over-import) - (syntax-e var) - req-path)) - (connect-syntaxes req-stx var actual? - (id-level phase-level var) - connections)))))))))) - + (when (and unused/phases phase-to-requires) + (define req-path/pr (get-module-req-path var phase-level)) + (define source-req-path/pr (get-module-req-path var phase-level #:nominal? #f)) + (when (and req-path/pr source-req-path/pr) + (define req-path (list-ref req-path/pr 0)) + (define id (list-ref req-path/pr 1)) + (define source-req-path (list-ref source-req-path/pr 3)) + (define source-id (list-ref source-req-path/pr 1)) + (define req-phase-level (list-ref req-path/pr 2)) + (define require-ht (hash-ref! phase-to-requires req-phase-level #f)) + (when require-ht + (define req-stxes (hash-ref require-ht req-path #f)) + (when req-stxes + (define unused (hash-ref! unused/phases req-phase-level #f)) + (when unused (hash-remove! unused req-path)) + (for ([req-stx (in-list req-stxes)]) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (define filename (get-require-filename source-req-path user-namespace user-directory)) + (when filename + (add-jump-to-definition + var + source-id + filename))) + (define raw-module-path (phaseless-spec->raw-module-path req-stx)) + (add-mouse-over var + (format + (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes (if (syntax-source raw-module-path) + raw-module-path + req-stx) + var actual? + (id-level phase-level var) + connections)))))))) + (define (id/require-match? var id req-stx) (match req-stx [`(only ,_ . ,ids) @@ -632,6 +629,15 @@ (eq? local-id var)] [else (eq? var id)])) + (define (phaseless-spec->raw-module-path stx) + (syntax-case* stx (only prefix all-expect prefix-all-except rename) symbolic-compare? + [(only raw-module-path id ...) #'raw-module-path] + [(prefix prefix-id raw-module-path) #'raw-module-path] + [(all-except raw-module-path id ...) #'raw-module-path] + [(prefix-all-except prefix-id raw-module-path id ...) #'raw-module-path] + [(rename raw-module-path local-id exported-id) #'raw-module-path] + [_ 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 diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index 92c0c52fd9..22210ccb09 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/collects/tests/drracket/syncheck-test.rkt @@ -730,7 +730,7 @@ ("x:foldl" imported-variable) (")" default-color)) (list '((10 18) (20 27)) - '((28 50) (52 59)))) + '((39 49) (52 59)))) (build-test "(module m mzscheme (require (prefix x: mzlib/list) mzlib/list) x:foldl foldl)" '(("(" default-color) @@ -743,7 +743,7 @@ ("foldl" imported-variable) (")" default-color)) (list '((10 18) (20 27)) - '((28 50) (63 70)) + '((39 49) (63 70)) '((51 61) (71 76)))) (build-test "(module m mzscheme (require (only mzlib/list foldr) (only mzlib/list foldl)) foldl foldr)" @@ -757,8 +757,8 @@ ("foldr" imported-variable) (")" default-color)) (list '((10 18) (20 27)) - '((28 51) (83 88)) - '((52 75) (77 82)))) + '((34 44) (83 88)) + '((58 68) (77 82)))) (build-test "(module m mzscheme (require (prefix x: mzscheme)) x:+ +)" '(("(" default-color) @@ -771,8 +771,8 @@ ("+" imported-variable) (")" default-color)) (list '((10 18) (20 27) (54 55)) - '((28 48) (50 53)))) - + '((39 47) (50 53)))) + (build-test "(module m mzscheme (require mzlib/etc) (rec f 1))" '(("(" default-color) ("module" imported-syntax)