diff options
| -rw-r--r-- | guix/packages.scm | 48 | ||||
| -rw-r--r-- | tests/packages.scm | 11 |
2 files changed, 58 insertions, 1 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 01de50ebd7..ad7937b4fb 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 2a290bc353..3756877270 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) |