packages: Use `read' and source properties for `package-field-location'.

* guix/packages.scm (package-field-location): Rewrite using `read' and
  source properties.  Change to return #f upon failure.
* tests/packages.scm ("package-field-location"): Check for #f upon failure.
* build-aux/sync-synopses.scm: Adjust accordingly.

3 files changed, 25 insertions, 37 deletions

diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm
index 3681b8c623..c1049d3398 100644
--- a/build-aux/sync-synopses.scm
+++ b/build-aux/sync-synopses.scm
@@ -52,7 +52,8 @@
            ((package . descriptor)
             (let ((upstream   (gnu-package-doc-summary descriptor))
                   (downstream (package-synopsis package))
-                  (loc        (package-field-location package 'synopsis)))
+                  (loc        (or (package-field-location package 'synopsis)
+                                  (package-location package))))
               (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 8490bfe438..ec5420f6c0 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -28,8 +28,6 @@
   #: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?
@@ -163,32 +161,13 @@ representation."
                                                       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))))))
+  "Return the source code location of the definition of FIELD for PACKAGE, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (= (port-column port) (- column 1))
+                 (= (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
 
   (match (package-location package)
     (($ <location> file line column)
@@ -196,14 +175,21 @@ for PACKAGE."
        (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))))))
+             (goto port line column)
+             (match (read port)
+               (('package inits ...)
+                (let ((field (assoc field inits)))
+                  (match field
+                    ((_ value)
+                     (and=> (or (source-properties value)
+                                (source-properties field))
+                            source-properties->location))
+                    (_
+                     #f))))
+               (_
+                #f)))))
        (lambda _
-         (package-location package))))
+         #f)))
     (_ #f)))
 
 
diff --git a/tests/packages.scm b/tests/packages.scm
index bf82aba858..22985d6e9a 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -71,7 +71,8 @@
     (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)))))
+                 (package-version %bootstrap-guile))
+         (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 
 (test-assert "package-transitive-inputs"
   (let* ((a (dummy-package "a"))