packages: ‘package-field-location’ returns a <location> for atoms.

Fixes guix/guix#1975.

When using ‘read’, ‘package-field-location’ would not get source location for
atoms such as symbols, typically making it impossible to get the location of
the value of a field list (build-system gnu-build-system).  This fixes that.

* guix/packages.scm (field-value-location): New procedure.
(package-field-location): Use it instead of inline code.
* tests/packages.scm ("package-field-location"): Test the ‘build-system’
field.

Reported-by: Nicolas Graves <ngraves@ngraves.fr>
Change-Id: I98c694bb6f1999fa9ca80e145fa016640067af55

guix/packages.scm

@@ -794,6 +794,42 @@ object."
     (name old-name)
     (properties `((superseded . ,p)))))
 
+(define* (field-value-location port field
+                               #:optional (file (port-filename port)))
+  "Return the source location of the value of FIELD as read from PORT, or #f
+if FIELD could not be found."
+  (define (field-value lst field)
+    (syntax-case lst ()
+      (()
+       #f)
+      (((binding value) rest ...)
+       (eq? (syntax->datum #'binding) field)
+       #'value)
+      ((_ rest ...)
+       (field-value #'(rest ...) field))))
+
+  (define (extract inits)
+    (and=> (field-value inits field)
+           (lambda (value)
+             (let ((loc (and=> (syntax-source value)
+                               source-properties->location)))
+               (and loc
+                    ;; Preserve the original file name, which
+                    ;; may be a relative file name.
+                    (set-field loc (location-file) file))))))
+
+  ;; Use 'read-syntax', not 'read', to get location info on all the tokens,
+  ;; including symbols.  Abuse 'syntax-case' for pattern matching on syntax
+  ;; objects.
+  (syntax-case (read-syntax port) ()
+    ((head inits ...)
+     (eq? (syntax->datum #'head) 'package)
+     (extract #'(inits ...)))
+    ((head _ inits ...)
+     (eq? (syntax->datum #'head) 'package/inherit)
+     (extract #'(inits ...)))
+    (x #f)))
+
 (define (package-field-location package field)
   "Return the source code location of the definition of FIELD for PACKAGE, or
 #f if it could not be determined."
@@ -807,22 +843,7 @@ object."
             (call-with-input-file file-found
               (lambda (port)
                 (go-to-location port line column)
-                (match (read port)
+                (field-value-location port field file))))
-                  ((or ('package inits ...)
-                       ('package/inherit _ inits ...))
-                   (let ((field (assoc field inits)))
-                     (match field
-                       ((_ value)
-                        (let ((loc (and=> (source-properties value)
-                                          source-properties->location)))
-                          (and loc
-                               ;; Preserve the original file name, which may be a
-                               ;; relative file name.
-                               (set-field loc (location-file) file))))
-                       (_
-                        #f))))
-                  (_
-                   #f)))))
           (lambda _
             #f)))
        (#f

tests/packages.scm

@@ -292,6 +292,9 @@
          (member (read-at (package-field-location %bootstrap-guile 'version))
                  (let ((version (package-version %bootstrap-guile)))
                    (list version `(version ,version))))
+         (member (read-at (package-field-location coreutils
+                                                  'build-system))
+                 '(build-system gnu-build-system))
          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 
 ;; Make sure we don't change the file name to an absolute file name.