ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: Use read' and source properties for package-field-location'.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

3
build-aux/sync-synopses.scm
View file

@ -52,7 +52,8 @@ (define gnus
((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~%"

56
guix/packages.scm
View file

@ -28,8 +28,6 @@ (define-module (guix packages)
#: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 @@ (define-record-type* <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))))))
"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 @@ (define (find-line port)
(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)))

3
tests/packages.scm
View file

@ -71,7 +71,8 @@ (define read-at
(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"))