~ruther/guix-local

3f26bfc18a70a65443688d7724e5f97c53855c01 — Ludovic Courtès 12 years ago 0820098
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.
3 files changed, 52 insertions(+), 64 deletions(-)

M gnu/packages.scm
M guix/scripts/build.scm
M guix/scripts/package.scm
M gnu/packages.scm => gnu/packages.scm +28 -15
@@ 33,6 33,7 @@
            %bootstrap-binaries-path
            fold-packages
            find-packages-by-name
            find-best-packages-by-name
            find-newest-available-packages))

;;; Commentary:


@@ 148,24 149,36 @@ then only return packages whose version is equal to VERSION."
                       result))
                 '()))

(define (find-newest-available-packages)
  "Return a vhash keyed by package names, and with
(define find-newest-available-packages
  (memoize
   (lambda ()
     "Return a vhash keyed by package names, and with
associated values of the form

  (newest-version newest-package ...)

where the preferred package is listed first."

  ;; FIXME: Currently, the preferred package is whichever one
  ;; was found last by 'fold-packages'.  Find a better solution.
  (fold-packages (lambda (p r)
                   (let ((name    (package-name p))
                         (version (package-version p)))
                     (match (vhash-assoc name r)
                       ((_ newest-so-far . pkgs)
                        (case (version-compare version newest-so-far)
                          ((>) (vhash-cons name `(,version ,p) r))
                          ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
                          ((<) r)))
                       (#f (vhash-cons name `(,version ,p) r)))))
                 vlist-null))
     ;; FIXME: Currently, the preferred package is whichever one
     ;; was found last by 'fold-packages'.  Find a better solution.
     (fold-packages (lambda (p r)
                      (let ((name    (package-name p))
                            (version (package-version p)))
                        (match (vhash-assoc name r)
                          ((_ newest-so-far . pkgs)
                           (case (version-compare version newest-so-far)
                             ((>) (vhash-cons name `(,version ,p) r))
                             ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
                             ((<) r)))
                          (#f (vhash-cons name `(,version ,p) r)))))
                    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 '()))))

M guix/scripts/build.scm => guix/scripts/build.scm +23 -35
@@ 32,8 32,7 @@
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:autoload   (gnu packages) (find-packages-by-name
                               find-newest-available-packages)
  #:autoload   (gnu packages) (find-best-packages-by-name)
  #:export (guix-build))

(define %store


@@ 57,6 56,27 @@ derivation of a package."
    ((? procedure? proc)
     (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.


@@ 212,38 232,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
         (leave (_ "failed to create GC root `~a': ~a~%")
                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
    ;; Ask for absolute file names so that .drv file names passed from the
    ;; 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.
                                     #f)
                                    (('argument . (? string? x))
                                     (let ((p (find-package x)))
                                     (let ((p (specification->package x)))
                                       (if src?
                                           (let ((s (package-source p)))
                                             (package-source-derivation

M guix/scripts/package.scm => guix/scripts/package.scm +1 -14
@@ 292,19 292,6 @@ return its return value."
       (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
       #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"))
  "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:


@@ 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,
or if the newest available version is equal to CURRENT-VERSION but would have
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)
     (case (version-compare candidate-version current-version)
       ((>) #t)