diff options
author | Ludovic Courtès <ludo@gnu.org> | 2018-09-17 09:55:31 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2018-09-21 17:04:37 +0200 |
commit | 6030396aec325b3c3287a472014bc2d530abb99d (patch) | |
tree | 00e125316a6336fd09bef3e4eb9e0fcb3db536aa | |
parent | e1a4ffdab52f616f41de4ff783a712bcd50a5187 (diff) | |
download | guix-6030396aec325b3c3287a472014bc2d530abb99d.tar.gz |
inferior: Add 'inferior-package-inputs' & co.
* guix/inferior.scm (open-inferior): Use (ice-9 match). (inferior-package-input-field, inferior-package-inputs): (inferior-package-native-inputs) (inferior-package-propagated-inputs) (inferior-package-transitive-propagated-inputs): New procedures. * tests/inferior.scm ("inferior-package-inputs"): New test. inputs fixlet
-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") |