aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-22 23:07:13 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-22 23:07:13 +0200
commitd66c70967f9bd792acdd00036292dc0a7b858742 (patch)
tree90e60b8fa1c2aa5e491d314c805f39cf4b11444f
parentb2a886f6c7c8424ce024020aaa8927be9811f40b (diff)
downloadguix-d66c70967f9bd792acdd00036292dc0a7b858742.tar
guix-d66c70967f9bd792acdd00036292dc0a7b858742.tar.gz
packages: Add `package-field-location'.
* guix/packages.scm (package-field-location): New procedure. * build-aux/sync-synopses.scm: Use it instead of `package-location'. * tests/packages.scm ("package-field-location"): New test.
-rw-r--r--build-aux/sync-synopses.scm2
-rw-r--r--guix/packages.scm47
-rw-r--r--tests/packages.scm21
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"