me
/
guix
Archived
1
0
Fork 0
Code

Factorize package search between 'guix package' and 'guix build'. 

* guix/scripts/package.scm (newest-available-packages): Remove.
  (find-best-packages-by-name): Move to...
* gnu/packages.scm (find-best-packages-by-name): ... here.
  (find-newest-available-packages): Memoize.
* guix/scripts/build.scm (specification->package): New procedure,
  formerly called 'find-package' within 'guix-build'.
  (guix-build): Adjust accordingly.
master
Ludovic Courtès 2013-12-21 22:36:32 +01:00
parent 0820098d1c
commit 3f26bfc18a
3 changed files with 52 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gnu/packages.scm
View File

@ -33,6 +33,7 @@
%bootstrap-binaries-path %bootstrap-binaries-path
fold-packages fold-packages
find-packages-by-name find-packages-by-name
find-best-packages-by-name
find-newest-available-packages)) find-newest-available-packages))
;;; Commentary: ;;; Commentary:
@ -148,24 +149,36 @@ then only return packages whose version is equal to VERSION."
result)) result))
'())) '()))
(define (find-newest-available-packages) (define find-newest-available-packages
"Return a vhash keyed by package names, and with (memoize
(lambda ()
"Return a vhash keyed by package names, and with
associated values of the form associated values of the form
(newest-version newest-package ...) (newest-version newest-package ...)
where the preferred package is listed first." where the preferred package is listed first."
;; FIXME: Currently, the preferred package is whichever one ;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution. ;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r) (fold-packages (lambda (p r)
(let ((name (package-name p)) (let ((name (package-name p))
(version (package-version p))) (version (package-version p)))
(match (vhash-assoc name r) (match (vhash-assoc name r)
((_ newest-so-far . pkgs) ((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far) (case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r)) ((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r)) ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r))) ((<) r)))
(#f (vhash-cons name `(,version ,p) r))))) (#f (vhash-cons name `(,version ,p) r)))))
vlist-null)) vlist-null))))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
version numbers; otherwise, return the list of packages named NAME and at
VERSION."
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (find-newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))

58
guix/scripts/build.scm
View File

@ -32,8 +32,7 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:autoload (gnu packages) (find-packages-by-name #:autoload (gnu packages) (find-best-packages-by-name)
find-newest-available-packages)
#:export (guix-build)) #:export (guix-build))
(define %store (define %store
@ -57,6 +56,27 @@ derivation of a package."
((? procedure? proc) ((? procedure? proc)
(run-with-store (%store) (proc) #:system system)))) (run-with-store (%store) (proc) #:system system))))
(define (specification->package spec)
"Return a package matching SPEC. SPEC may be a package name, or a package
name followed by a hyphen and a version number. If the version number is not
present, return the preferred newest version."
(let-values (((name version)
(package-name->name+version spec)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
;;; ;;;
;;; Command-line options. ;;; Command-line options.
@ -212,38 +232,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(leave (_ "failed to create GC root `~a': ~a~%") (leave (_ "failed to create GC root `~a': ~a~%")
root (strerror (system-error-errno args))))))) root (strerror (system-error-errno args)))))))
(define newest-available-packages
(memoize find-newest-available-packages))
(define (find-best-packages-by-name name version)
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))
(define (find-package request)
;; Return a package matching REQUEST. REQUEST may be a package
;; name, or a package name followed by a hyphen and a version
;; number. If the version number is not present, return the
;; preferred newest version.
(let-values (((name version)
(package-name->name+version request)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") request)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
(with-error-handling (with-error-handling
;; Ask for absolute file names so that .drv file names passed from the ;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns. ;; user to 'read-derivation' are absolute when it returns.
@ -268,7 +256,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
;; Nothing to do; maybe for --log-file. ;; Nothing to do; maybe for --log-file.
#f) #f)
(('argument . (? string? x)) (('argument . (? string? x))
(let ((p (find-package x))) (let ((p (specification->package x)))
(if src? (if src?
(let ((s (package-source p))) (let ((s (package-source p)))
(package-source-derivation (package-source-derivation

15
guix/scripts/package.scm
View File

@ -292,19 +292,6 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT) (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f)))) #f))))
(define newest-available-packages
(memoize find-newest-available-packages))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
version numbers; otherwise, return the list of packages named NAME and at
VERSION."
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))
(define* (specification->package+output spec #:optional (output "out")) (define* (specification->package+output spec #:optional (output "out"))
"Find the package and output specified by SPEC, or #f and #f; SPEC may "Find the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples: optionally contain a version number and an output name, as in these examples:
@ -342,7 +329,7 @@ version; if SPEC does not specify an output, return OUTPUT."
"Return #t if there's a version of package NAME newer than CURRENT-VERSION, "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
or if the newest available version is equal to CURRENT-VERSION but would have or if the newest available version is equal to CURRENT-VERSION but would have
an output path different than CURRENT-PATH." an output path different than CURRENT-PATH."
(match (vhash-assoc name (newest-available-packages)) (match (vhash-assoc name (find-newest-available-packages))
((_ candidate-version pkg . rest) ((_ candidate-version pkg . rest)
(case (version-compare candidate-version current-version) (case (version-compare candidate-version current-version)
((>) #t) ((>) #t)