guix_mirror_bot pushed a commit to branch master
in repository guix.
commit a5ac56f8830928205ce5424082486d509f898dc7
Author: Ludovic Courtès <[email protected]>
AuthorDate: Thu Sep 4 14:28:42 2025 +0200
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 <[email protected]>
Change-Id: I98c694bb6f1999fa9ca80e145fa016640067af55
---
guix/packages.scm | 53 +++++++++++++++++++++++++++++++++++++----------------
tests/packages.scm | 3 +++
2 files changed, 40 insertions(+), 16 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 1d5986c5f4..bba281b374 100644
--- a/guix/packages.scm
+++ b/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)
- ((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)))))
+ (field-value-location port field file))))
(lambda _
#f)))
(#f
diff --git a/tests/packages.scm b/tests/packages.scm
index f56c63128d..78cb670815 100644
--- a/tests/packages.scm
+++ b/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.
