~ruther/guix-local

a3d73f59e35e19561afde1bf60ef881a4e8db0e7 — Ludovic Courtès 13 years ago d5f0c7c
Add `package-transitive-inputs'; use it to honor propagated inputs.

* guix/packages.scm (package-transitive-inputs): New procedure.
  (package-derivation): Use it to compute INPUTS.

* tests/packages.scm (dummy-package): New macro.
  ("package-transitive-inputs"): New test.
2 files changed, 51 insertions(+), 2 deletions(-)

M guix/packages.scm
M tests/packages.scm
M guix/packages.scm => guix/packages.scm +23 -2
@@ 57,6 57,7 @@
            package-properties
            package-location

            package-transitive-inputs
            package-source-derivation
            package-derivation
            package-cross-derivation))


@@ 161,6 162,27 @@ representation."
    (($ <origin> uri method sha256 name)
     (method store uri 'sha256 sha256 name))))

(define (package-transitive-inputs package)
  "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
with their propagated inputs, recursively."
  (let loop ((inputs (concatenate (list (package-native-inputs package)
                                        (package-inputs package)
                                        (package-propagated-inputs package))))
             (result '()))
    (match inputs
      (()
       (delete-duplicates (reverse result)))      ; XXX: efficiency
      (((and i (name (? package? p) sub ...)) rest ...)
       (let ((t (map (match-lambda
                      ((dep-name derivation ...)
                       (cons (string-append name "/" dep-name)
                             derivation)))
                     (package-propagated-inputs p))))
         (loop (append t rest)
               (append t (cons i result)))))
      ((input rest ...)
       (loop rest (cons input result))))))

(define* (package-derivation store package
                             #:optional (system (%current-system)))
  "Return the derivation of PACKAGE for SYSTEM."


@@ 186,8 208,7 @@ representation."
                          (list name
                                (add-to-store store (basename file)
                                              #t #f "sha256" file))))
                        (concatenate (list native-inputs inputs
                                           propagated-inputs)))))
                        (package-transitive-inputs package))))
       (apply builder
              store (string-append name "-" version)
              (package-source-derivation store source)

M tests/packages.scm => tests/packages.scm +28 -0
@@ 22,6 22,7 @@
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system gnu)
  #:use-module (distro)
  #:use-module (distro base)
  #:use-module (srfi srfi-26)


@@ 35,6 36,32 @@

(test-begin "packages")

(define-syntax-rule (dummy-package name* extra-fields ...)
  (package (name name*) (version "0") (source #f)
           (build-system gnu-build-system)
           (description #f) (long-description #f)
           (home-page #f)
           extra-fields ...))

(test-assert "package-transitive-inputs"
  (let* ((a (dummy-package "a"))
         (b (dummy-package "b"
              (propagated-inputs `(("a" ,a)))))
         (c (dummy-package "c"
              (inputs `(("a" ,a)))))
         (d (dummy-package "d"
              (propagated-inputs `(("x" "something.drv")))))
         (e (dummy-package "e"
              (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
    (and (null? (package-transitive-inputs a))
         (equal? `(("a" ,a)) (package-transitive-inputs b))
         (equal? `(("a" ,a)) (package-transitive-inputs c))
         (equal? (package-propagated-inputs d)
                 (package-transitive-inputs d))
         (equal? `(("b" ,b) ("b/a" ,a) ("c" ,c)
                   ("d" ,d) ("d/x" "something.drv"))
                 (pk 'x (package-transitive-inputs e))))))

(test-skip (if (not %store) 1 0))

(test-assert "GNU Hello"


@@ 63,4 90,5 @@

;;; Local Variables:
;;; eval: (put 'test-assert 'scheme-indent-function 1)
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End: