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:
parent
e1a4ffdab5
commit
6030396aec
|
@ -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
|
||||||
|
|
|
@ -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")
|
||||||
|
|
Loading…
Reference in New Issue