diff options
| -rw-r--r-- | guix/inferior.scm | 51 | ||||
| -rw-r--r-- | tests/inferior.scm | 34 |
2 files changed, 84 insertions, 1 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index 81b71d0c77..ca819c6eff 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -33,6 +33,7 @@ #:select (read-derivation-from-file)) #:use-module (guix gexp) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 vlist) @@ -53,6 +54,10 @@ inferior-package-description inferior-package-home-page inferior-package-location + inferior-package-inputs + inferior-package-native-inputs + inferior-package-propagated-inputs + inferior-package-transitive-propagated-inputs inferior-package-derivation)) ;;; Commentary: @@ -120,6 +125,7 @@ equivalent. Return #f if the inferior could not be launched." (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(use-modules (ice-9 match)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -271,6 +277,51 @@ record." loc))) package-location)))) +(define (inferior-package-input-field package field) + "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an +inferior package." + (define field* + `(compose (lambda (inputs) + (map (match-lambda + ;; XXX: Origins are not handled. + ((label (? package? package) rest ...) + (let ((id (object-address package))) + (hashv-set! %package-table id package) + `(,label (package ,id + ,(package-name package) + ,(package-version package)) + ,@rest))) + (x + x)) + inputs)) + ,field)) + + (define inputs + (inferior-package-field package field*)) + + (define inferior + (inferior-package-inferior package)) + + (map (match-lambda + ((label ('package id name version) . rest) + ;; XXX: eq?-ness of inferior packages is not preserved here. + `(,label ,(inferior-package inferior name version id) + ,@rest)) + (x x)) + inputs)) + +(define inferior-package-inputs + (cut inferior-package-input-field <> 'package-inputs)) + +(define inferior-package-native-inputs + (cut inferior-package-input-field <> 'package-native-inputs)) + +(define inferior-package-propagated-inputs + (cut inferior-package-input-field <> 'package-propagated-inputs)) + +(define inferior-package-transitive-propagated-inputs + (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) + (define (proxy client backend) ;adapted from (guix ssh) "Proxy communication between CLIENT and BACKEND until CLIENT closes the connection, at which point CLIENT is closed (both CLIENT and BACKEND must be diff --git a/tests/inferior.scm b/tests/inferior.scm index 791e30b179..03170a19c9 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -24,8 +24,10 @@ #:use-module (guix derivations) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -108,6 +110,36 @@ (close-inferior inferior) (every eq? lst1 lst2))) +(test-equal "inferior-package-inputs" + (let ((->list (match-lambda + ((label (? package? package) . rest) + `(,label + (package ,(package-name package) + ,(package-version package) + ,(package-location package)) + ,@rest))))) + (list (map ->list (package-inputs guile-2.2)) + (map ->list (package-native-inputs guile-2.2)) + (map ->list (package-propagated-inputs guile-2.2)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (->list (match-lambda + ((label (? inferior-package? package) . rest) + `(,label + (package ,(inferior-package-name package) + ,(inferior-package-version package) + ,(inferior-package-location package)) + ,@rest)))) + (result (list (map ->list (inferior-package-inputs guile)) + (map ->list + (inferior-package-native-inputs guile)) + (map ->list + (inferior-package-propagated-inputs + guile))))) + (close-inferior inferior) + result)) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") |