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
This commit is contained in:
Ludovic Courtès 2018-09-17 09:55:31 +02:00
parent e1a4ffdab5
commit 6030396aec
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 84 additions and 1 deletions

View File

@ -33,6 +33,7 @@
#:select (read-derivation-from-file)) #:select (read-derivation-from-file))
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 popen) #:use-module (ice-9 popen)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
@ -53,6 +54,10 @@
inferior-package-description inferior-package-description
inferior-package-home-page inferior-package-home-page
inferior-package-location inferior-package-location
inferior-package-inputs
inferior-package-native-inputs
inferior-package-propagated-inputs
inferior-package-transitive-propagated-inputs
inferior-package-derivation)) inferior-package-derivation))
;;; Commentary: ;;; Commentary:
@ -120,6 +125,7 @@ equivalent. Return #f if the inferior could not be launched."
(delay (%inferior-package-table result))))) (delay (%inferior-package-table result)))))
(inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (guix)) result)
(inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (gnu)) result)
(inferior-eval '(use-modules (ice-9 match)) result)
(inferior-eval '(define %package-table (make-hash-table)) (inferior-eval '(define %package-table (make-hash-table))
result) result)
result)) result))
@ -271,6 +277,51 @@ record."
loc))) loc)))
package-location)))) 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) (define (proxy client backend) ;adapted from (guix ssh)
"Proxy communication between CLIENT and BACKEND until CLIENT closes the "Proxy communication between CLIENT and BACKEND until CLIENT closes the
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be connection, at which point CLIENT is closed (both CLIENT and BACKEND must be

View File

@ -24,8 +24,10 @@
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (gnu packages guile)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64)
#:use-module (ice-9 match))
(define %top-srcdir (define %top-srcdir
(dirname (search-path %load-path "guix.scm"))) (dirname (search-path %load-path "guix.scm")))
@ -108,6 +110,36 @@
(close-inferior inferior) (close-inferior inferior)
(every eq? lst1 lst2))) (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" (test-equal "inferior-package-derivation"
(map derivation-file-name (map derivation-file-name
(list (package-derivation %store %bootstrap-guile "x86_64-linux") (list (package-derivation %store %bootstrap-guile "x86_64-linux")