~ruther/guix-local

91c9b5d016ac8bed127557d378c70fbc56cec0e5 — Ludovic Courtès 8 years ago f3e3f4d
packages: 'package-grafts' trims native inputs.

'package-grafts' returns a list of potentially applicable grafts, which
'cumulative-grafts' then narrows by looking at store item references and
determining the subset of the grafts that's actually applicable.

Until now, 'package-grafts' would traverse native inputs and would thus
return a large superset of the applicable grafts, since native inputs
are not in the reference graph by definition.  This patch fixes that by
having 'package-grafts' ignore entirely native inputs from the
dependency graph.

* guix/packages.scm (fold-bag-dependencies)[bag-direct-inputs*]: Add
special case for libc.
* guix/packages.scm (bag-grafts)[native-grafts, target-grafts]: Remove.
[grafts]: New procedure.
Use it.
* tests/packages.scm ("package-grafts, grafts of native inputs
ignored"): New test.
2 files changed, 49 insertions(+), 22 deletions(-)

M guix/packages.scm
M tests/packages.scm
M guix/packages.scm => guix/packages.scm +31 -22
@@ 1004,7 1004,21 @@ dependencies; otherwise, restrict to target dependencies."
                  (if (bag-target bag)
                      '()
                      (bag-host-inputs bag))))
        bag-host-inputs))
        (lambda (bag)
          (if (bag-target bag)
              (bag-host-inputs bag)

              ;; XXX: Currently libc wrongfully ends up in 'build-inputs',
              ;; even tough it's something that's still referenced at run time
              ;; and thus conceptually a 'host-inputs'.  Because of that, we
              ;; re-add it here.
              (if (assoc-ref (bag-host-inputs bag) "libc")
                  (bag-host-inputs bag)
                  (append (let ((libc (assoc-ref (bag-build-inputs bag)
                                                 "libc")))
                            (or (and libc `(("libc" ,@libc)))
                                '()))
                          (bag-host-inputs bag)))))))

  (define nodes
    (match (bag-direct-inputs* bag)


@@ 1038,33 1052,28 @@ to (see 'graft-derivation'.)"
  (define system (bag-system bag))
  (define target (bag-target bag))

  (define native-grafts
    (let ((->graft (input-graft store system)))
      (fold-bag-dependencies (lambda (package grafts)
                               (match (->graft package)
                                 (#f    grafts)
                                 (graft (cons graft grafts))))
                             '()
                             bag)))

  (define target-grafts
    (if target
        (let ((->graft (input-cross-graft store target system)))
          (fold-bag-dependencies (lambda (package grafts)
                                   (match (->graft package)
                                     (#f    grafts)
                                     (graft (cons graft grafts))))
                                 '()
                                 bag
                                 #:native? #f))
        '()))
  (define (grafts package->graft)
    (fold-bag-dependencies (lambda (package grafts)
                             (match (package->graft package)
                               (#f    grafts)
                               (graft (cons graft grafts))))
                           '()
                           bag

                           ;; Grafts that apply to native inputs do not matter
                           ;; since, by definition, native inputs are not
                           ;; referred to at run time.  Thus, ignore
                           ;; 'native-inputs' and focus on the others.
                           #:native? #f))

  ;; We can end up with several identical grafts if we stumble upon packages
  ;; that are not 'eq?' but map to the same derivation (this can happen when
  ;; using things like 'package-with-explicit-inputs'.)  Hence the
  ;; 'delete-duplicates' call.
  (delete-duplicates
   (append native-grafts target-grafts)))
   (if target
       (grafts (input-cross-graft store target system))
       (grafts (input-graft store system)))))

(define* (package-grafts store package
                         #:optional (system (%current-system))

M tests/packages.scm => tests/packages.scm +18 -0
@@ 660,6 660,24 @@
;;     (package-cross-derivation %store p "mips64el-linux-gnu"
;;                               #:graft? #t)))

;; It doesn't make sense for 'package-grafts' to look at native inputs since,
;; by definition, they are not referenced at run time.  Make sure
;; 'package-grafts' respects this.
(test-equal "package-grafts, grafts of native inputs ignored"
  '()
  (let* ((new   (dummy-package "native-dep"
                  (version "0.1")
                  (arguments '(#:implicit-inputs? #f))))
         (ndep  (package (inherit new) (version "0.0")
                         (replacement new)))
         (dep   (dummy-package "dep"
                  (arguments '(#:implicit-inputs? #f))))
         (dummy (dummy-package "dummy"
                  (arguments '(#:implicit-inputs? #f))
                  (native-inputs `(("ndep" ,ndep)))
                  (inputs `(("dep" ,dep))))))
    (package-grafts %store dummy)))

(test-assert "package-grafts, indirect grafts"
  (let* ((new   (dummy-package "dep"
                  (arguments '(#:implicit-inputs? #f))))