futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

packages: Add 'package-definition-location'.

Browse Source 
Suggested by Maxime Devos <maximedevos@telenet.be>.

* guix/packages.scm (current-definition-location): New syntax parameter.
(define-public*): New macro.
(<package>)[definition-location]: New field.
(package-definition-location): New procedure.
* tests/packages.scm ("package-definition-location"): New test.
This commit is contained in:
Ludovic Courtès 2021-09-07 21:19:11 +02:00
parent 10c981b135
commit 8531997d2a
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 58 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
guix/packages.scm
View File

@ -52,6 +52,7 @@
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
#:replace ((define-public* . define-public))
#:export (content-hash
content-hash?
content-hash-algorithm
@ -99,6 +100,7 @@
package-supported-systems
package-properties
package-location
package-definition-location
hidden-package
hidden-package?
package-superseded
@ -385,6 +387,35 @@ one-indexed line numbers."
(location-line loc)
(location-column loc)))))
(define-syntax-parameter current-definition-location
;; Location of the encompassing 'define-public'.
(const #f))
(define-syntax define-public*
(lambda (s)
"Like 'define-public' but set 'current-definition-location' for the
lexical scope of its body."
(define location
(match (syntax-source s)
(#f #f)
(properties
(let ((line (assq-ref properties 'line))
(column (assq-ref properties 'column)))
;; Don't repeat the file name since it's redundant with 'location'.
;; Encode the whole thing so that it fits in a fixnum on 32-bit
;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is
;; almost always zero), and 22 bits for LINE.
(and line column
(logior (ash (logand #x7f column) 22)
(logand (- (expt 2 22) 1) (+ 1 line))))))))
(syntax-case s ()
((_ prototype body ...)
#`(define-public prototype
(syntax-parameterize ((current-definition-location
(lambda (s) #,location)))
body ...))))))
;; A package.
(define-record-type* <package>
package make-package
@ -430,7 +461,10 @@ one-indexed line numbers."
(location package-location-vector
(default (current-location-vector))
(innate) (sanitize sanitize-location)))
(innate) (sanitize sanitize-location))
(definition-location package-definition-location-code
(default (current-definition-location))
(innate)))
(set-record-type-printer! <package>
(lambda (package port)
@ -455,6 +489,18 @@ it is not known."
(#f #f)
(#(file line column) (location file line column))))
(define (package-definition-location package)
"Like 'package-location', but return the location of the definition
itself--i.e., that of the enclosing 'define-public' form, if any, or #f."
(match (package-definition-location-code package)
(#f #f)
(code
(let ((column (bit-extract code 22 29))
(line (bit-extract code 0 21)))
(match (package-location-vector package)
(#f #f)
(#(file _ _) (location file line column)))))))
(define-syntax-rule (package/inherit p overrides ...)
"Like (package (inherit P) OVERRIDES ...), except that the same
transformation is done to the package P's replacement, if any. P must be a bare

11
tests/packages.scm
View File

@ -236,6 +236,17 @@
(eq? item new)))
(null? (manifest-transaction-remove tx)))))))
(test-assert "package-definition-location"
(let ((location (package-location hello))
(definition (package-definition-location hello)))
;; Check for the usual layout of (define-public hello (package ...)).
(and (string=? (location-file location)
(location-file definition))
(= 0 (location-column definition))
(= 2 (location-column location))
(= (location-line definition)
(- (location-line location) 1)))))
(test-assert "package-field-location"
(let ()
(define (goto port line column)