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.
This commit is contained in:
Ludovic Courtès 2013-04-24 14:43:31 +02:00
parent 5fe21fbeef
commit f903dc056a
3 changed files with 25 additions and 37 deletions

View File

@ -52,7 +52,8 @@
((package . descriptor) ((package . descriptor)
(let ((upstream (gnu-package-doc-summary descriptor)) (let ((upstream (gnu-package-doc-summary descriptor))
(downstream (package-synopsis package)) (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)) (unless (and upstream (string=? upstream downstream))
(format (guix-warning-port) (format (guix-warning-port)
"~a: ~a: proposed synopsis: ~s~%" "~a: ~a: proposed synopsis: ~s~%"

View File

@ -28,8 +28,6 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module (ice-9 regex)
#:re-export (%current-system) #:re-export (%current-system)
#:export (origin #:export (origin
origin? origin?
@ -163,32 +161,13 @@ representation."
16))))) 16)))))
(define (package-field-location package field) (define (package-field-location package field)
"Return an estimate of the source code location of the definition of FIELD "Return the source code location of the definition of FIELD for PACKAGE, or
for PACKAGE." #f if it could not be determined."
(define field-rx (define (goto port line column)
(make-regexp (string-append "\\(" (unless (and (= (port-column port) (- column 1))
(regexp-quote (symbol->string field)) (= (port-line port) (- line 1)))
"[[:blank:]]*"))) (unless (eof-object? (read-char port))
(define (seek-to-line port line) (goto port line column))))
(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) (match (package-location package)
(($ <location> file line column) (($ <location> file line column)
@ -196,14 +175,21 @@ for PACKAGE."
(lambda () (lambda ()
(call-with-input-file (search-path %load-path file) (call-with-input-file (search-path %load-path file)
(lambda (port) (lambda (port)
(seek-to-line port line) (goto port line column)
(let-values (((line column) (match (read port)
(find-line port))) (('package inits ...)
(if (and line column) (let ((field (assoc field inits)))
(location file line column) (match field
(package-location package)))))) ((_ value)
(and=> (or (source-properties value)
(source-properties field))
source-properties->location))
(_
#f))))
(_
#f)))))
(lambda _ (lambda _
(package-location package)))) #f)))
(_ #f))) (_ #f)))

View File

@ -71,7 +71,8 @@
(and (equal? (read-at (package-field-location %bootstrap-guile 'name)) (and (equal? (read-at (package-field-location %bootstrap-guile 'name))
(package-name %bootstrap-guile)) (package-name %bootstrap-guile))
(equal? (read-at (package-field-location %bootstrap-guile 'version)) (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" (test-assert "package-transitive-inputs"
(let* ((a (dummy-package "a")) (let* ((a (dummy-package "a"))