338 lines
14 KiB
Racket
338 lines
14 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract
|
|
(only-in racket/function curry)
|
|
racket/list
|
|
racket/match
|
|
"identifier.rkt"
|
|
"syntax.rkt")
|
|
|
|
(provide find-definition
|
|
find-definition/drracket-jump
|
|
find-signature)
|
|
|
|
(module+ test
|
|
(require rackunit
|
|
racket/format))
|
|
|
|
;; Note: Unfortunately identifier-binding can't report the definition
|
|
;; id in the case of a contract-out and a rename-out, both. For
|
|
;; `(provide (contract-out [rename orig new contract]))`
|
|
;; identifier-binding reports (1) the contract wrapper as the id, and
|
|
;; (2) `new` as the nominal-id -- but NOT (3) `orig`. We handle such
|
|
;; cases; see `find-def-in-file` and its use of `$renaming-provde`,
|
|
;; below.
|
|
;;
|
|
;; Another tricky case: "foo" is defined in def.rkt. repro.rkt
|
|
;; requires def.rkt and re-provides "foo" using contract-out. When
|
|
;; user.rkt requires repro.rkt, identifier-binding will report "foo"
|
|
;; the id (yay!) but report the defining file is repro.rkt -- not
|
|
;; def.rkt (boo!). We handle such cases.
|
|
|
|
(define location/c (list/c path-string? natural-number/c natural-number/c))
|
|
|
|
;; Try to find a definition, using as a head start information
|
|
;; supplied by drracket/check-syntax. It did the "fast" work for all
|
|
;; uses (calling identifier-binding) and we recorded that answer to
|
|
;; give the front end. If the user wants to visit any of those, the
|
|
;; front end gives us that info, and we do the "slow" work.
|
|
(define/contract (find-definition/drracket-jump how-path src-path submods id-strs)
|
|
(-> (and/c how/c (not/c 'namespace)) path-string? (listof symbol?) (listof string?)
|
|
(or/c #f 'kernel location/c))
|
|
(or (for/or ([id-str (in-list id-strs)])
|
|
(match (find-def-in-file (string->symbol id-str) how-path src-path submods)
|
|
[(list stx path _submods)
|
|
(list (->path-string (or (syntax-source stx) path))
|
|
(or (syntax-line stx) 1)
|
|
(or (syntax-column stx) 0))]
|
|
[v v]))
|
|
;; Handle possible re-provide with a contract: Try again
|
|
;; starting with that other src-path. i.e. Do automatically what
|
|
;; the user could: Open that file, and try visit-definition
|
|
;; again, there. from that.
|
|
(and (not (path-string-equal? how-path src-path))
|
|
(for/or ([id-str (in-list id-strs)])
|
|
(find-definition src-path id-str)))
|
|
;; As a final fallback, return the reported file:1:0. At least
|
|
;; give user a head start.
|
|
(list src-path 1 0)))
|
|
|
|
;; Try to find a definition.
|
|
(define/contract (find-definition how str)
|
|
(-> how/c string?
|
|
(or/c #f 'kernel location/c))
|
|
(match (find-def how str)
|
|
[(list stx path _submods)
|
|
(list (->path-string (or (syntax-source stx) path))
|
|
(or (syntax-line stx) 1)
|
|
(or (syntax-column stx) 0))]
|
|
[v v]))
|
|
|
|
;; Try to find the definition of `str`, returning its signature or #f.
|
|
;; When defined in 'kernel, returns a form saying so, not #f.
|
|
(define/contract (find-signature how str)
|
|
(-> how/c string?
|
|
(or/c #f pair?))
|
|
(match (find-def how str)
|
|
['kernel '("defined in #%kernel, signature unavailable")]
|
|
[(list id-stx path submods)
|
|
(get-syntax how path
|
|
(λ (mod-stx)
|
|
(match ($signature (syntax-e id-stx)
|
|
(submodule-syntax submods mod-stx))
|
|
[(? syntax? stx) (syntax->datum stx)]
|
|
[_ #f])))]
|
|
[v v]))
|
|
|
|
(define stx+path+mods/c (list/c syntax? path-string? (listof symbol?)))
|
|
|
|
(define/contract (find-def how str)
|
|
(-> how/c string?
|
|
(or/c #f 'kernel stx+path+mods/c))
|
|
(->identifier-resolved-binding-info
|
|
how str
|
|
(λ (results)
|
|
(match results
|
|
[(? list? bindings)
|
|
(or (for/or ([x (in-list (remove-duplicates bindings))])
|
|
(match x
|
|
[(cons _id 'kernel) 'kernel]
|
|
[(list* id path submods) (find-def-in-file id how path submods)]))
|
|
;; Handle possible re-provide with a contract: Try again
|
|
;; starting with that other src-path. i.e. Automatically
|
|
;; do what the user could: Open that file, and try
|
|
;; visit-definition again, there.
|
|
(match results
|
|
[(list (list* src-id src-path src-subs)
|
|
(list* nom-id _))
|
|
(or (and (or (equal? how 'namespace)
|
|
(not (path-string-equal? how src-path)))
|
|
(for/or ([id (in-list (list src-id nom-id))])
|
|
(find-def (path->string src-path) (symbol->string id))))
|
|
;; As a final fallback, return the reported
|
|
;; file:1:0. At least give user a head start.
|
|
(list (datum->syntax #f src-id (list src-path 1 0 #f #f))
|
|
src-path
|
|
'()))]
|
|
[_ #f]))]
|
|
[_ #f]))))
|
|
|
|
(define/contract (find-def-in-file id-sym how path submods)
|
|
(-> symbol? how/c path-string? (listof symbol?)
|
|
(or/c #f stx+path+mods/c))
|
|
(define subs (curry submodule-syntax submods))
|
|
(match (or (get-expanded-syntax
|
|
how path
|
|
(λ (stx)
|
|
($definition id-sym (subs stx))))
|
|
(get-syntax
|
|
how path
|
|
(λ (stx)
|
|
(match ($renaming-provide id-sym (subs stx))
|
|
[(? identifier? id)
|
|
(define id-sym (syntax-e id))
|
|
(get-expanded-syntax
|
|
how path
|
|
(λ (stx)
|
|
($definition id-sym (subs stx))))]
|
|
[_ #f]))))
|
|
[(? syntax? stx) (list stx path submods)]
|
|
[_ #f]))
|
|
|
|
;; Given a submodule path as a list of symbols, and the syntax for a
|
|
;; file's entire module form: Return the (sub)module contents as
|
|
;; #'(begin . contents).
|
|
(define/contract (submodule-syntax sub-mod-syms stx)
|
|
(-> (listof symbol?) syntax? (or/c #f syntax?))
|
|
;; Prepend #f as the outermost module name to match, meaning "any".
|
|
(sub-stx (cons #f sub-mod-syms) stx))
|
|
|
|
(define (sub-stx mods stx)
|
|
(match-define (cons this more) mods)
|
|
(define (subs stxs)
|
|
(if (empty? more)
|
|
#`(begin . #,stxs)
|
|
(ormap (λ (stx) (sub-stx more stx))
|
|
(syntax->list stxs))))
|
|
(syntax-case* stx (module #%module-begin) syntax-e-eq?
|
|
[(module name _ (#%module-begin . stxs))
|
|
(or (not this) (eq? this (syntax-e #'name)))
|
|
(subs #'stxs)]
|
|
[(module name _ . stxs)
|
|
(or (not this) (eq? this (syntax-e #'name)))
|
|
(subs #'stxs)]
|
|
[_ #f]))
|
|
|
|
(module+ test
|
|
(check-equal? (syntax->datum
|
|
(submodule-syntax '(a b c)
|
|
#'(module file racket
|
|
(module a racket
|
|
(module not-b racket #f)
|
|
(module b racket
|
|
(module not-c racket #f)
|
|
(module c racket "bingo")
|
|
(module not-c racket #f))
|
|
(module not-b racket #f)))))
|
|
'(begin "bingo")))
|
|
|
|
;; Given a symbol and syntax, return syntax corresponding to the
|
|
;; definition. Intentionally does NOT walk into module forms, so, give
|
|
;; us the module bodies wrapped in begin.
|
|
;;
|
|
;; If `stx` is expanded we can find things defined via definer
|
|
;; macros.
|
|
;;
|
|
;; If `stx` is not expanded, we will miss some things, however the
|
|
;; syntax will be closer to what a human expects -- e.g. `(define (f
|
|
;; x) x)` instead of `(define-values (f) (lambda (x) x))`.
|
|
(define ($definition sym stx) ;;symbol? syntax? -> syntax?
|
|
(define eq-sym? (make-eq-sym? sym))
|
|
;; This is a hack to handle definer macros that neglect to set
|
|
;; srcloc properly using syntax/loc or (format-id ___ #:source __):
|
|
;; If the stx lacks srcloc and its parent stx has srcloc, return the
|
|
;; parent stx instead. Caveats: 1. Assumes caller only cares about
|
|
;; the srcloc. 2. We only check immediate parent. 3. We only use
|
|
;; this for define-values and define-syntaxes, below, on the
|
|
;; assumption that this only matters for fully-expanded syntax.
|
|
(define (loc s)
|
|
(if (and (not (syntax-line s))
|
|
(syntax-line stx))
|
|
stx
|
|
s))
|
|
(syntax-case* stx
|
|
(begin define-values define-syntaxes
|
|
define define/contract
|
|
define-syntax struct define-struct)
|
|
syntax-e-eq?
|
|
[(begin . stxs) (ormap (λ (stx) ($definition sym stx))
|
|
(syntax->list #'stxs))]
|
|
[(define (s . _) . _) (eq-sym? #'s) stx]
|
|
[(define/contract (s . _) . _) (eq-sym? #'s) stx]
|
|
[(define s . _) (eq-sym? #'s) stx]
|
|
[(define-values (ss ...) . _) (ormap eq-sym? (syntax->list #'(ss ...)))
|
|
(loc (ormap eq-sym? (syntax->list #'(ss ...))))]
|
|
[(define-syntax (s . _) . _) (eq-sym? #'s) stx]
|
|
[(define-syntax s . _) (eq-sym? #'s) stx]
|
|
[(define-syntaxes (ss ...) . _) (ormap eq-sym? (syntax->list #'(ss ...)))
|
|
(loc (ormap eq-sym? (syntax->list #'(ss ...))))]
|
|
[(define-struct s . _) (eq-sym? #'s) stx]
|
|
[(define-struct (s _) . _) (eq-sym? #'s) stx]
|
|
[(struct s . _) (eq-sym? #'s) stx]
|
|
[(struct (s _) . _) (eq-sym? #'s) stx]
|
|
[_ #f]))
|
|
|
|
;; Given a symbol and syntax, return syntax corresponding to the
|
|
;; function definition signature. The input syntax should NOT be
|
|
;; `expand`ed. This intentionally does NOT walk into module forms, so,
|
|
;; give us the module bodies wrapped in begin.
|
|
(define ($signature sym stx) ;;symbol? syntax? -> (or/c #f list?)
|
|
(define eq-sym? (make-eq-sym? sym))
|
|
(syntax-case* stx (begin define define/contract case-lambda) syntax-e-eq?
|
|
[(begin . stxs) (ormap (λ (stx) ($signature sym stx))
|
|
(syntax->list #'stxs))]
|
|
[(define (s . as) . _) (eq-sym? #'s) #'(s . as)]
|
|
[(define/contract (s . as) . _) (eq-sym? #'s) #'(s . as)]
|
|
[(define s (case-lambda [(ass ...) . _] ...)) (eq-sym? #'s) #'((s ass ...) ...)]
|
|
[_ #f]))
|
|
|
|
;; Find sym in a contracting and/or renaming provide, and return the
|
|
;; syntax for the ORIGINAL identifier (before being contracted and/or
|
|
;; renamed). The input syntax should NOT be expanded.
|
|
(define ($renaming-provide sym stx) ;;symbol? syntax? -> syntax?
|
|
(define eq-sym? (make-eq-sym? sym))
|
|
(syntax-case* stx (begin provide provide/contract) syntax-e-eq?
|
|
[(begin . stxs)
|
|
(ormap (λ (stx) ($renaming-provide sym stx))
|
|
(syntax->list #'stxs))]
|
|
[(provide/contract . stxs)
|
|
(for/or ([stx (syntax->list #'stxs)])
|
|
(syntax-case stx ()
|
|
[(s _) (eq-sym? #'s)]
|
|
[_ #f]))]
|
|
[(provide . stxs)
|
|
(for/or ([stx (syntax->list #'stxs)])
|
|
(syntax-case* stx (contract-out rename-out) syntax-e-eq?
|
|
[(contract-out . stxs)
|
|
(for/or ([stx (syntax->list #'stxs)])
|
|
(syntax-case* stx (rename) syntax-e-eq?
|
|
[(rename orig s _) (eq-sym? #'s) #'orig]
|
|
[(s _) (eq-sym? #'s) #'s]
|
|
[_ #f]))]
|
|
[(rename-out . stxs)
|
|
(for/or ([stx (syntax->list #'stxs)])
|
|
(syntax-case* stx () syntax-e-eq?
|
|
[(orig s) (eq-sym? #'s) #'orig]
|
|
[_ #f]))]
|
|
[_ #f]))]
|
|
[_ #f]))
|
|
|
|
(module+ test
|
|
;; Just a quick smoke test. See test/find.rkt for many more tests.
|
|
;;
|
|
;; Exercise where the "how" is a path-string, meaning look up that
|
|
;; path from our cache, not on disk.
|
|
(let ([path-str "/tmp/x.rkt"]
|
|
[code-str (~a `(module x racket/base
|
|
(define (module-function-binding x y z) (+ 1 x))
|
|
(define module-variable-binding 42)))])
|
|
(string->expanded-syntax path-str code-str void)
|
|
(check-equal? (find-signature path-str "module-function-binding")
|
|
'(module-function-binding x y z))
|
|
(check-equal? (find-definition path-str "module-function-binding")
|
|
`(,path-str 1 31))
|
|
(check-equal? (find-definition path-str "module-variable-binding")
|
|
`(,path-str 1 79)))
|
|
;; Exercise the "make-traversal" scenario described in comments
|
|
;; above.
|
|
(let ([path-str "/tmp/x.rkt"]
|
|
[code-str (~a `(module x racket/base
|
|
(require drracket/check-syntax)
|
|
"make-traversal"))])
|
|
(string->expanded-syntax path-str code-str void)
|
|
(check-match (find-definition path-str "make-traversal")
|
|
(list (pregexp "private/syncheck/traversals.rkt$") _ _))))
|
|
|
|
;; These `get-syntax` and `get-expanded-syntax` functions handle where
|
|
;; we get the syntax.
|
|
;;
|
|
;; The special case is when `how` is a path-string. That path doesn't
|
|
;; necessarily exist as a file, or the file may be outdated. The path
|
|
;; may simply be the syntax-source for a string from an unsaved Emacs
|
|
;; buffer. So when we need to get syntax for such a path, we need to
|
|
;; get it from our cache -- NOT from a file. (How it got in the cache
|
|
;; previously was from some check-syntax.)
|
|
;;
|
|
;; Things like identifier-binding may tell us to look at such a path,
|
|
;; or at a path for a real existing/updated file. This helps sort out
|
|
;; the various cases.
|
|
|
|
(define (get-syntax how path-str k)
|
|
(match how
|
|
['namespace (file->syntax path-str k)]
|
|
[(? path-string? how-path) (if (path-string-equal? path-str how-path)
|
|
(path->existing-syntax path-str k)
|
|
(file->syntax path-str k))]))
|
|
|
|
;; For when we use syntax-case* simply for syntax-e equality.
|
|
(define (syntax-e-eq? a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
|
|
(define ((make-eq-sym? sym) stx)
|
|
(and (eq? sym (syntax-e stx)) stx))
|
|
|
|
(define (get-expanded-syntax how path-str k)
|
|
(match how
|
|
['namespace (file->expanded-syntax path-str k)]
|
|
[(? path-string? how-path) (if (path-string-equal? path-str how-path)
|
|
(path->existing-expanded-syntax path-str k)
|
|
(file->expanded-syntax path-str k))]))
|
|
|
|
(define (path-string-equal? a b)
|
|
(equal? (->path-string a)
|
|
(->path-string b)))
|
|
|
|
(define (->path-string v)
|
|
(cond [(path? v) (path->string v)]
|
|
[(path-string? v) v]
|
|
[else (error 'path-string-equal? "not a path or path-string?" v)]))
|