futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

inferior: Add 'inferior-package-inputs' & co.

Browse Source 
* 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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
guix/inferior.scm
View File

@ -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

34
tests/inferior.scm
View File

@ -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")