amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Ludovic Courtès 2025-09-04 14:28:42 +02:00
parent fd4402f09a
commit a5ac56f883
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 40 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

53
guix/packages.scm
View file

@ -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

3
tests/packages.scm
View file

@ -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.