packages: Add `package-field-location'.

* guix/packages.scm (package-field-location): New procedure.
* build-aux/sync-synopses.scm: Use it instead of `package-location'.
* tests/packages.scm ("package-field-location"): New test.

3 files changed, 69 insertions, 1 deletions

diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm
index 9aaff11ce0..3681b8c623 100644
--- a/build-aux/sync-synopses.scm
+++ b/build-aux/sync-synopses.scm
@@ -52,7 +52,7 @@
            ((package . descriptor)
             (let ((upstream   (gnu-package-doc-summary descriptor))
                   (downstream (package-synopsis package))
-                  (loc        (package-location package)))
+                  (loc        (package-field-location package 'synopsis)))
               (unless (and upstream (string=? upstream downstream))
                 (format (guix-warning-port)
                         "~a: ~a: proposed synopsis: ~s~%"
diff --git a/guix/packages.scm b/guix/packages.scm
index 81f09d638e..8490bfe438 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -28,6 +28,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module (ice-9 regex)
   #:re-export (%current-system)
   #:export (origin
             origin?
@@ -58,6 +60,7 @@
             package-maintainers
             package-properties
             package-location
+            package-field-location
 
             package-transitive-inputs
             package-transitive-propagated-inputs
@@ -159,6 +162,50 @@ representation."
                                                        package)
                                                       16)))))
 
+(define (package-field-location package field)
+  "Return an estimate of the source code location of the definition of FIELD
+for PACKAGE."
+  (define field-rx
+    (make-regexp (string-append "\\("
+                                (regexp-quote (symbol->string field))
+                                "[[:blank:]]*")))
+  (define (seek-to-line port line)
+    (let ((line (- line 1)))
+      (let loop ()
+        (when (< (port-line port) line)
+          (unless (eof-object? (read-line port))
+            (loop))))))
+
+  (define (find-line port)
+    (let loop ((line (read-line port)))
+      (cond ((eof-object? line)
+             (values #f #f))
+            ((regexp-exec field-rx line)
+             =>
+             (lambda (match)
+               ;; At this point `port-line' points to the next line, so need
+               ;; need to add one.
+               (values (port-line port)
+                       (match:end match))))
+            (else
+             (loop (read-line port))))))
+
+  (match (package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         (call-with-input-file (search-path %load-path file)
+           (lambda (port)
+             (seek-to-line port line)
+             (let-values (((line column)
+                           (find-line port)))
+               (if (and line column)
+                   (location file line column)
+                   (package-location package))))))
+       (lambda _
+         (package-location package))))
+    (_ #f)))
+
 
 ;; Error conditions.
 
diff --git a/tests/packages.scm b/tests/packages.scm
index c5d9d280ed..bf82aba858 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -52,6 +52,27 @@
            (home-page #f) (license #f)
            extra-fields ...))
 
+(test-assert "package-field-location"
+  (let ()
+    (define (goto port line column)
+      (unless (and (= (port-column port) (- column 1))
+                   (= (port-line port) (- line 1)))
+        (unless (eof-object? (get-char port))
+          (goto port line column))))
+
+    (define read-at
+      (match-lambda
+       (($ <location> file line column)
+        (call-with-input-file (search-path %load-path file)
+          (lambda (port)
+            (goto port line column)
+            (read port))))))
+
+    (and (equal? (read-at (package-field-location %bootstrap-guile 'name))
+                 (package-name %bootstrap-guile))
+         (equal? (read-at (package-field-location %bootstrap-guile 'version))
+                 (package-version %bootstrap-guile)))))
+
 (test-assert "package-transitive-inputs"
   (let* ((a (dummy-package "a"))
          (b (dummy-package "b"