aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-24 14:43:31 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-25 00:13:56 +0200
commitf903dc056a5176033daca7a69d5b2c8376ff0677 (patch)
treee7ca982e7ba57d22245a048c37223ff9f9947ea7
parent5fe21fbeefe109f400aef40a51f71af111546fa3 (diff)
downloadguix-f903dc056a5176033daca7a69d5b2c8376ff0677.tar
guix-f903dc056a5176033daca7a69d5b2c8376ff0677.tar.gz
packages: Use `read' and source properties for `package-field-location'.
* guix/packages.scm (package-field-location): Rewrite using `read' and source properties. Change to return #f upon failure. * tests/packages.scm ("package-field-location"): Check for #f upon failure. * build-aux/sync-synopses.scm: Adjust accordingly.
-rw-r--r--build-aux/sync-synopses.scm3
-rw-r--r--guix/packages.scm56
-rw-r--r--tests/packages.scm3
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"))