diff options
| -rw-r--r-- | build-aux/sync-synopses.scm | 2 | ||||
| -rw-r--r-- | guix/packages.scm | 47 | ||||
| -rw-r--r-- | tests/packages.scm | 21 |
3 files changed, 69 insertions, 1 deletions
diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm index 9aaff11ce0..3681b8c623 100644 --- a/build-aux/sync-synopses.scm +++ b/build-aux/sync-synopses.scm @@ -52,7 +52,7 @@ ((package . descriptor) (let ((upstream (gnu-package-doc-summary descriptor)) (downstream (package-synopsis package)) - (loc (package-location package))) + (loc (package-field-location package 'synopsis))) (unless (and upstream (string=? upstream downstream)) (format (guix-warning-port) "~a: ~a: proposed synopsis: ~s~%" diff --git a/guix/packages.scm b/guix/packages.scm index 81f09d638e..8490bfe438 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,6 +28,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (ice-9 regex) #:re-export (%current-system) #:export (origin origin? @@ -58,6 +60,7 @@ package-maintainers package-properties package-location + package-field-location package-transitive-inputs package-transitive-propagated-inputs @@ -159,6 +162,50 @@ representation." package) 16))))) +(define (package-field-location package field) + "Return an estimate of the source code location of the definition of FIELD +for PACKAGE." + (define field-rx + (make-regexp (string-append "\\(" + (regexp-quote (symbol->string field)) + "[[:blank:]]*"))) + (define (seek-to-line port line) + (let ((line (- line 1))) + (let loop () + (when (< (port-line port) line) + (unless (eof-object? (read-line port)) + (loop)))))) + + (define (find-line port) + (let loop ((line (read-line port))) + (cond ((eof-object? line) + (values #f #f)) + ((regexp-exec field-rx line) + => + (lambda (match) + ;; At this point `port-line' points to the next line, so need + ;; need to add one. + (values (port-line port) + (match:end match)))) + (else + (loop (read-line port)))))) + + (match (package-location package) + (($ <location> file line column) + (catch 'system + (lambda () + (call-with-input-file (search-path %load-path file) + (lambda (port) + (seek-to-line port line) + (let-values (((line column) + (find-line port))) + (if (and line column) + (location file line column) + (package-location package)))))) + (lambda _ + (package-location package)))) + (_ #f))) + ;; Error conditions. diff --git a/tests/packages.scm b/tests/packages.scm index c5d9d280ed..bf82aba858 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -52,6 +52,27 @@ (home-page #f) (license #f) extra-fields ...)) +(test-assert "package-field-location" + (let () + (define (goto port line column) + (unless (and (= (port-column port) (- column 1)) + (= (port-line port) (- line 1))) + (unless (eof-object? (get-char port)) + (goto port line column)))) + + (define read-at + (match-lambda + (($ <location> file line column) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (read port)))))) + + (and (equal? (read-at (package-field-location %bootstrap-guile 'name)) + (package-name %bootstrap-guile)) + (equal? (read-at (package-field-location %bootstrap-guile 'version)) + (package-version %bootstrap-guile))))) + (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) (b (dummy-package "b" |