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.

1 files changed, 47 insertions, 0 deletions

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.