[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/08: packages: Add 'package-definition-location'.
From: |
guix-commits |
Subject: |
02/08: packages: Add 'package-definition-location'. |
Date: |
Mon, 13 Sep 2021 06:33:03 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 8531997d2a1e10d574a6e9ab70bc86ade6af4733
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Sep 7 21:19:11 2021 +0200
packages: Add 'package-definition-location'.
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.
---
guix/packages.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++++-
tests/packages.scm | 11 +++++++++++
2 files changed, 58 insertions(+), 1 deletion(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 01de50e..ad7937b 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -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
diff --git a/tests/packages.scm b/tests/packages.scm
index 2a290bc..3756877 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -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)
- branch master updated (53f54d4 -> ec0e05f), guix-commits, 2021/09/13
- 01/08: packages: Store 'location' field as a literal vector., guix-commits, 2021/09/13
- 03/08: gnu: Prefix licenses in docbook module., guix-commits, 2021/09/13
- 02/08: packages: Add 'package-definition-location'.,
guix-commits <=
- 05/08: gnu: lxc: Generate man pages., guix-commits, 2021/09/13
- 07/08: gnu: i3lock-fancy: Add input., guix-commits, 2021/09/13
- 04/08: gnu: Add docbook2x., guix-commits, 2021/09/13
- 06/08: gnu: i3lock: Update to 2.13., guix-commits, 2021/09/13
- 08/08: gnu: Add i3lock-blur., guix-commits, 2021/09/13