Improve racket-find-definition

The goal is to eliminate situations where you're plopped at the start
of a file because we couldn't find the definition location within the
file.

- Racket's `identifier-binding` returns two symbol/file answers --
  "plain" and "nominal". Use `for/or` to try each uniformly until we
  find an answer. ("Try" means looking for a symbol that
  `identifier-binding` directly gave us, as well as the case where it
  doesn't due to a provide involving both a contract and a rename.)

- Add a hack to compensate for definer macros that don't provide
  source location for the definition syntax: If the parent syntax
  does, use its location. (A definer macro ought to use `syntax/loc`
  or the `#:source` argument to `format-id`, to ensure that the
  identifier syntax has full source location. For macros that do not,
  at least now we can show the location of some macro syntax closely
  related to the definition, and hopefully nearby in the source file.)

- More thorough tests.

defn.rkt

@@ -19,67 +19,51 @@
 ;; Try to find the definition of `str`, returning a list with the file
 ;; name, line and column, 'kernel, or #f if not found.
 (define (find-definition str)
-  (match (source str)
-    [(list _  'kernel) 'kernel]
-    [(list id (? path? where))
-     (match (define-in-stx id (file->syntax where #:expand? #t))
-       [(? syntax? stx) (list (path->string (or (syntax-source stx) where))
-                              (or (syntax-line stx) 1)
-                              (or (syntax-column stx) 0))]
-       [_               (list (path->string where) 1 0)])]
-    [_ #f]))
+  (match (find-definition/stx str)
+    [(cons stx where)
+     (list (path->string (or (syntax-source stx) where))
+           (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 (find-signature str)
-  (match (source str)
-    [(list _  'kernel) '("defined in #%kernel, signature unavailable")]
-    [(list id (? path? where))
-     (match (signature-in-stx id (file->syntax where #:expand? #f))
+  (match (find-definition/stx str)
+    ['kernel '("defined in #%kernel, signature unavailable")]
+    [(cons stx where)
+     (match (signature (syntax-e stx) (file->syntax where #:expand? #f))
        [(? syntax? stx) (syntax->datum stx)]
        [_ #f])]
-    [_ #f]))
+    [v v]))
 
-;; Use `identifier-binding*' but don't trust its results. Check for a
-;; couple special cases.
-(define/contract (source str)
-  (-> string?
-      (or/c #f (list/c symbol? (or/c path? 'kernel #f))))
+(define (find-definition/stx str)
+  ;; (-> string? (or/c #f 'kernel (cons/c syntax? path?)))
   (match (identifier-binding* str)
-    [(list id 'kernel _ _) (list id 'kernel)]
-    [(list id (? path? where) nom-id nom-where)
-     (define file-stx (file->syntax where #:expand? #f))
-     (or
-      ;; First look for a possible renaming/contracting provide
-      ;; involving `nom-id`. Because in that case the `id` that
-      ;; `identifier-binding` gave us likely isn't used in the
-      ;; definition. `renaming-provide-in-stx` will return
-      ;; syntax for that actual id, which it gets from
-      ;; examining the provide form. Use _that_ to search for
-      ;; the definition form.
-      (match (renaming-provide-in-stx nom-id file-stx)
-        [(? syntax? stx) (list (syntax-e stx) where)]
-        [_ #f])
-      ;; Look for the case where the definition is actually
-      ;; nom-id not id. This can happen e.g. with Typed Racket
-      ;; definitions. Check for this using `define-in-stx` on
-      ;; NON-expanded stx.
-      (match (define-in-stx nom-id file-stx)
-        [(? syntax? stx) (list nom-id nom-where)]
-        [_ #f])
-      ;; Otherwise accept what identifier-binding* said.
-      (list id where))]
+    [(? list? xs)
+     (for/or ([x (in-list xs)])
+       (match x
+         [(cons id 'kernel) 'kernel]
+         [(cons id (? path? where))
+          (define expanded (file->syntax where #:expand? #t))
+          (define stx
+            (or (definition id expanded)
+                ;; Handle rename + contract
+                (match (renaming-provide id (file->syntax where #:expand? #f))
+                  [(? syntax? stx) (definition (syntax-e stx) expanded)]
+                  [_ #f])))
+          (and stx
+               (cons stx where))]))]
     [_ #f]))
 
 ;; A wrapper for identifier-binding. Keep in mind that unfortunately
 ;; it can't report the definition id in the case of a contract-out and
-;; a rename-out, both. Ex: For `(provide (contract-out rename orig new
-;; contract))` it reports (1) the id for the contract-wrapper, and (2)
-;; `new`, but NOT (3) `orig`.
+;; a rename-out, both. For `(provide (contract-out [rename orig new
+;; contract]))` it reports (1) the contract-wrapper as the id, and (2)
+;; `new` as the nominal-id -- but NOT (3) `orig`.
 (define/contract (identifier-binding* v)
   (-> (or/c string? symbol? identifier?)
-      (or/c #f (list/c symbol? (or/c path? 'kernel #f)
-                       symbol? (or/c path? 'kernel #f))))
+      (or/c #f (listof (cons/c symbol? (or/c path? 'kernel #f)))))
   (define sym->id namespace-symbol->identifier)
   (define id (cond [(string? v)     (sym->id (string->symbol v))]
                    [(symbol? v)     (sym->id v)]
@@ -95,8 +79,8 @@
          [(? symbol? sym)              (sym->path sym)]
          [(list (? symbol? sym) _ ...) (sym->path sym)]
          [_                            #f]))
-     (list source-id         (mpi->path source-mpi)
-           nominal-source-id (mpi->path nominal-source-mpi))]
+     (list (cons source-id         (mpi->path source-mpi))
+           (cons nominal-source-id (mpi->path nominal-source-mpi)))]
     [_ #f]))
 
 ;; When module source is 'sym or '(sym sym1 ...) treat it as "sym.rkt"
@@ -114,7 +98,7 @@
                    (thunk
                     (with-input-from-file file read-syntax/count-lines)))))
     (if expand?
-        (expand stx) ;; do this while current-load-relative-directory is set
+        (expand stx) ;expand while current-load-relative-directory is set
         stx)))
 
 (define (read-syntax/count-lines)
@@ -124,31 +108,43 @@
 ;; Given a symbol? and syntax?, return syntax? corresponding to the
 ;; definition.
 ;;
-;; If `stx` is run through expand we can find things defined via
-;; definer macros.
+;; If `stx` is expanded we can find things defined via definer
+;; macros.
 ;;
-;; If `stx` is not run through expand, 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 (define-in-stx sym stx) ;;symbol? syntax? -> syntax?
+;; 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 syntx/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
       (module #%module-begin define-values define-syntaxes
               define define/contract
               define-syntax struct define-struct)
       syntax-e=?
     [(module _ _ (#%module-begin . stxs))
-     (ormap (λ (stx) (define-in-stx sym stx))
+     (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 ...)))
-                                    (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 ...)))
-                                    (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]
@@ -158,18 +154,18 @@
 ;; Given a symbol? and syntax?, return syntax? corresponding to the
 ;; function definition signature. Note that we do NOT want stx to be
 ;; run through `expand`.
-(define (signature-in-stx sym stx) ;;symbol? syntax? -> (or/c #f list?)
+(define (signature sym stx) ;;symbol? syntax? -> (or/c #f list?)
   (define eq-sym? (make-eq-sym? sym))
   (syntax-case* stx
       (module #%module-begin define define/contract case-lambda)
       syntax-e=?
     [(module _ _ (#%module-begin . stxs))
      (ormap (λ (stx)
-              (signature-in-stx sym stx))
+              (signature sym stx))
             (syntax->list #'stxs))]
     [(module _ _ . stxs)
      (ormap (λ (stx)
-              (signature-in-stx sym stx))
+              (signature sym stx))
             (syntax->list #'stxs))]
     [(define          (s . as) . _)               (eq-sym? #'s) #'(s . as)]
     [(define/contract (s . as) . _)               (eq-sym? #'s) #'(s . as)]
@@ -181,13 +177,13 @@
 ;; `expand` because we want the original contract definitions (if
 ;; any). ** This is currently not used. If we ever add a
 ;; `find-provision` function, it would use this.
-(define (contracting-provide-in-stx sym stx) ;;symbol? syntax? -> syntax?
+(define (contracting-provide sym stx) ;;symbol? syntax? -> syntax?
   (define eq-sym? (make-eq-sym? sym))
   (syntax-case* stx
       (module #%module-begin provide provide/contract)
       syntax-e=?
     [(module _ _ (#%module-begin . ss))
-     (ormap (λ (stx) (contracting-provide-in-stx sym stx))
+     (ormap (λ (stx) (contracting-provide sym stx))
             (syntax->list #'ss))]
     [(provide/contract . stxs)
      (for/or ([stx (syntax->list #'stxs)])
@@ -213,13 +209,13 @@
 ;; Find sym in a contracting and/or renaming provide, and return the
 ;; syntax for the ORIGINAL identifier (before being contracted and/or
 ;; renamed).
-(define (renaming-provide-in-stx sym stx) ;;symbol? syntax? -> syntax?
+(define (renaming-provide sym stx) ;;symbol? syntax? -> syntax?
   (define eq-sym? (make-eq-sym? sym))
   (syntax-case* stx
       (module #%module-begin provide provide/contract)
       syntax-e=?
     [(module _ _ (#%module-begin . ss))
-     (ormap (λ (stx) (renaming-provide-in-stx sym stx))
+     (ormap (λ (stx) (renaming-provide sym stx))
             (syntax->list #'ss))]
     [(provide/contract . stxs)
      (for/or ([stx (syntax->list #'stxs)])
@@ -249,18 +245,3 @@
 
 (define ((make-eq-sym? sym) stx)
   (and (eq? sym (syntax-e stx)) stx))
-
-(module+ test
-  (require racket/list
-           racket/runtime-path
-           rackunit)
-  (define-runtime-path defn.rkt "defn.rkt")
-  (when (string<=? (version) "6.0")
-    (current-namespace (module->namespace defn.rkt)))
-  (check-equal? (find-definition "display") 'kernel)
-  (check-equal? (find-signature "display")
-                '("defined in #%kernel, signature unavailable"))
-  (check-match (find-definition "displayln")
-               (list* (pregexp "/racket/private/misc\\.rkt$") _))
-  (check-equal? (find-signature "displayln")
-                '((displayln v) (displayln v p)))) ;case-lambda defn

makefile

@@ -57,7 +57,9 @@ doc:
 test: test-racket test-elisp
 
 test-racket:
-	raco test -x ./*.rkt  # not example/*.rkt
+	raco test ./test/
+	raco test -x ./*.rkt # not example/*.rkt
+
 
 test-elisp:
 	$(BATCHEMACS) -l ert -l racket-tests.el -f ert-run-tests-batch-and-exit

test/defn-examples.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+(require racket/contract)
+
+;; For tests of defn.rkt.
+;;
+;; Until I can figure out how to make this work as a submodule of its
+;; `test` submodule.
+
+(define (plain x) x)
+(provide plain)
+(provide (rename-out [plain renamed]))
+
+(define (contracted1 x) x)
+(provide (contract-out [contracted1 (-> any/c any)]))
+(define (contracted2 x) x)
+(provide/contract [contracted2 (-> any/c any)])
+
+(define (c/r x) x)
+(provide (contract-out [rename c/r contracted/renamed (-> any/c any)]))
+
+(define-syntax-rule (plain-definer name)
+  (begin
+    (define (name x) x)
+    (provide name)))
+(plain-definer plain-by-macro)
+
+(define-syntax-rule (contracted-definer name)
+  (begin
+    (define (name x) x)
+    (provide (contract-out [name (-> any/c any)]))))
+(contracted-definer contracted-by-macro)
+
+

test/defn.rkt

@@ -0,0 +1,101 @@
+#lang at-exp racket/base
+
+(require racket/format
+         racket/match
+         racket/runtime-path
+         rackunit
+         syntax/modread
+         "../defn.rkt"
+         "defn-examples.rkt")
+
+(define-runtime-path dot-dot "..")
+
+(define-namespace-anchor nsa)
+(parameterize ([current-namespace (namespace-anchor->namespace nsa)])
+  (define (not-0 v) (not (= 0 v)))
+  (define (not-1 v) (not (= 1 v)))
+
+  (check-equal? (find-definition "display")
+                'kernel)
+  (check-equal? (find-signature "display")
+                '("defined in #%kernel, signature unavailable"))
+
+  (check-match (find-definition "displayln")
+               (list (pregexp "/racket/private/misc\\.rkt$")
+                     (? not-1)
+                     (? not-0)))
+  (check-equal? (find-signature "displayln")
+                '((displayln v) (displayln v p))) ;case-lambda defn
+
+  ;; Test a definer macro that (as of Racket 6.7) does not properly
+  ;; set srcloc: Can we at least return a specfic location for its
+  ;; parent syntax (as opposed to line 1 column 0)?
+  (check-match (find-definition "in-hash")
+               (list (pregexp "/racket/private/for.rkt$")
+                     (? not-1)
+                     (? not-0)))
+
+  ;; Tests for specific locations in defn-examples.rkt
+
+  (check-match (find-definition "plain")
+               (list (pregexp "defn-examples.rkt$") 10 9))
+  (check-equal? (find-signature "plain")
+                '(plain x))
+
+  (check-match (find-definition "renamed")
+               (list (pregexp "defn-examples.rkt$") 10 9))
+  (check-equal? (find-signature "renamed")
+                '(plain x))
+
+  (check-match (find-definition "contracted1")
+               (list (pregexp "defn-examples.rkt$") 14 9))
+  (check-equal? (find-signature "contracted1")
+                '(contracted1 x))
+
+  (check-match (find-definition "contracted2")
+               (list (pregexp "defn-examples.rkt$") 16 9))
+  (check-equal? (find-signature "contracted2")
+                '(contracted2 x))
+
+  (check-match (find-definition "contracted/renamed")
+               (list (pregexp "defn-examples.rkt$") 19 9))
+  (check-equal? (find-signature "contracted/renamed")
+                '(c/r x))
+
+  (check-match (find-definition "plain-by-macro")
+               (list (pregexp "defn-examples.rkt$") 26 15))
+  (check-false (find-signature "plain-by-macro"))
+
+  (check-match (find-definition "contracted-by-macro")
+               (list (pregexp "defn-examples.rkt$") 32 20))
+  (check-false (find-signature "contracted-by-macro"))
+
+
+  ;; This is (roughly) a test of opening a Racket source file and
+  ;; doing M-. on every non-list sexpr: Call find-definition on each
+  ;; sexpr. Not-found (#f) is fine. But fail test for (list _ 1 0) --
+  ;; i.e. the source file was found, but not the location within.
+  (define (check-non-bof-location file)
+    (define ht (make-hash))
+    (define (find k) ;memoized find-definition
+      (hash-ref ht k
+                (λ ()
+                  (define v (find-definition (format "~a" k)))
+                  (hash-set! ht k v)
+                  v)))
+    (define (walk v)
+      (if (list? v)
+          (for-each walk v)
+          (match (find v)
+                    [(list where 1 0)
+                     (fail @~a{can't find definition of `@|v|` in @where})]
+                    [_ (void)])))
+    (walk
+     (with-module-reading-parameterization
+       ;; Why read not read-syntax? Because we only care about the
+       ;; sexprs as text: `find-definition` takes a string, because
+       ;; `racket-visit-definition` takes text from an Emacs buffer.
+       (λ () (with-input-from-file file read)))))
+  (for ([file '("cmds.rkt"
+                "run.rkt")])
+    (check-non-bof-location (build-path dot-dot file))))