06/12: inferior: Add 'inferior-package-inputs' & co.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 6030396aec325b3c3287a472014bc2d530abb99d
Author: Ludovic Courtès <address@hidden>
Date:   Mon Sep 17 09:55:31 2018 +0200

    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
---
 guix/inferior.scm  | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/inferior.scm | 34 +++++++++++++++++++++++++++++++++-
 2 files changed, 84 insertions(+), 1 deletion(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 81b71d0..ca819c6 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 791e30b..03170a1 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")