diff options
| -rw-r--r-- | build-aux/sync-synopses.scm | 3 | ||||
| -rw-r--r-- | guix/packages.scm | 56 | ||||
| -rw-r--r-- | tests/packages.scm | 3 |
3 files changed, 25 insertions, 37 deletions
diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm index 3681b8c623..c1049d3398 100644 --- a/build-aux/sync-synopses.scm +++ b/build-aux/sync-synopses.scm @@ -52,7 +52,8 @@ ((package . descriptor) (let ((upstream (gnu-package-doc-summary descriptor)) (downstream (package-synopsis package)) - (loc (package-field-location package 'synopsis))) + (loc (or (package-field-location package 'synopsis) + (package-location package)))) (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 8490bfe438..ec5420f6c0 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,8 +28,6 @@ #: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? @@ -163,32 +161,13 @@ representation." 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)))))) + "Return the source code location of the definition of FIELD for PACKAGE, or +#f if it could not be determined." + (define (goto port line column) + (unless (and (= (port-column port) (- column 1)) + (= (port-line port) (- line 1))) + (unless (eof-object? (read-char port)) + (goto port line column)))) (match (package-location package) (($ <location> file line column) @@ -196,14 +175,21 @@ for PACKAGE." (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)))))) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + (and=> (or (source-properties value) + (source-properties field)) + source-properties->location)) + (_ + #f)))) + (_ + #f))))) (lambda _ - (package-location package)))) + #f))) (_ #f))) diff --git a/tests/packages.scm b/tests/packages.scm index bf82aba858..22985d6e9a 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -71,7 +71,8 @@ (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))))) + (package-version %bootstrap-guile)) + (not (package-field-location %bootstrap-guile 'does-not-exist))))) (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) |