05/12: inferior: Add 'lookup-inferior-packages'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e1a4ffdab52f616f41de4ff783a712bcd50a5187
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 15 14:50:14 2018 +0200

    inferior: Add 'lookup-inferior-packages'.
    
    * guix/inferior.scm (<inferior>)[packages, table]: New fields.
    (open-inferior): Initialize these new fields.
    (inferior-packages): Rename to...
    (%inferior-packages): ... this.
    (inferior-packages): New procedure; force the promise.
    (%inferior-package-table, lookup-inferior-packages): New procedures.
    * tests/inferior.scm ("lookup-inferior-packages")
    ("lookup-inferior-packages and eq?-ness"): New tests.
---
 guix/inferior.scm  | 47 +++++++++++++++++++++++++++++++++++++++++------
 tests/inferior.scm | 29 +++++++++++++++++++++++++++++
 2 files changed, 70 insertions(+), 6 deletions(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 5bef964..81b71d0 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -22,7 +22,8 @@
   #:use-module ((guix utils)
                 #:select (%current-system
                           source-properties->location
-                          call-with-temporary-directory))
+                          call-with-temporary-directory
+                          version>? version-prefix?))
   #:use-module ((guix store)
                 #:select (nix-server-socket
                           nix-server-major-version
@@ -31,8 +32,10 @@
   #:use-module ((guix derivations)
                 #:select (read-derivation-from-file))
   #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
+  #:use-module (ice-9 vlist)
   #:use-module (ice-9 binary-ports)
   #:export (inferior?
             open-inferior
@@ -45,6 +48,7 @@
             inferior-package-version
 
             inferior-packages
+            lookup-inferior-packages
             inferior-package-synopsis
             inferior-package-description
             inferior-package-home-page
@@ -61,11 +65,13 @@
 
 ;; Inferior Guix process.
 (define-record-type <inferior>
-  (inferior pid socket version)
+  (inferior pid socket version packages table)
   inferior?
   (pid      inferior-pid)
   (socket   inferior-socket)
-  (version  inferior-version))                    ;REPL protocol version
+  (version  inferior-version)                    ;REPL protocol version
+  (packages inferior-package-promise)            ;promise of inferior packages
+  (table    inferior-package-table))             ;promise of vhash
 
 (define (inferior-pipe directory command)
   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
@@ -109,7 +115,9 @@ equivalent.  Return #f if the inferior could not be 
launched."
 
   (match (read pipe)
     (('repl-version 0 rest ...)
-     (let ((result (inferior 'pipe pipe (cons 0 rest))))
+     (letrec ((result (inferior 'pipe pipe (cons 0 rest)
+                                (delay (%inferior-packages result))
+                                (delay (%inferior-package-table result)))))
        (inferior-eval '(use-modules (guix)) result)
        (inferior-eval '(use-modules (gnu)) result)
        (inferior-eval '(define %package-table (make-hash-table))
@@ -181,8 +189,8 @@ equivalent.  Return #f if the inferior could not be 
launched."
 
 (set-record-type-printer! <inferior-package> write-inferior-package)
 
-(define (inferior-packages inferior)
-  "Return the list of packages known to INFERIOR."
+(define (%inferior-packages inferior)
+  "Compute the list of inferior packages from INFERIOR."
   (let ((result (inferior-eval
                  '(fold-packages (lambda (package result)
                                    (let ((id (object-address package)))
@@ -198,6 +206,33 @@ equivalent.  Return #f if the inferior could not be 
launched."
             (inferior-package inferior name version id)))
          result)))
 
+(define (inferior-packages inferior)
+  "Return the list of packages known to INFERIOR."
+  (force (inferior-package-promise inferior)))
+
+(define (%inferior-package-table inferior)
+  "Compute a package lookup table for INFERIOR."
+  (fold (lambda (package table)
+          (vhash-cons (inferior-package-name package) package
+                      table))
+        vlist-null
+        (inferior-packages inferior)))
+
+(define* (lookup-inferior-packages inferior name #:optional version)
+  "Return the sorted list of inferior packages matching NAME in INFERIOR, with
+highest version numbers first.  If VERSION is true, return only packages with
+a version number prefixed by VERSION."
+  ;; This is the counterpart of 'find-packages-by-name'.
+  (sort (filter (lambda (package)
+                  (or (not version)
+                      (version-prefix? version
+                                       (inferior-package-version package))))
+                (vhash-fold* cons '() name
+                             (force (inferior-package-table inferior))))
+        (lambda (p1 p2)
+          (version>? (inferior-package-version p1)
+                     (inferior-package-version p2)))))
+
 (define (inferior-package-field package getter)
   "Return the field of PACKAGE, an inferior package, accessed with GETTER."
   (let ((inferior (inferior-package-inferior package))
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 817fcb6..791e30b 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -79,6 +79,35 @@
            (close-inferior inferior)
            result))))
 
+(test-equal "lookup-inferior-packages"
+  (let ((->list (lambda (package)
+                  (list (package-name package)
+                        (package-version package)
+                        (package-location package)))))
+    (list (map ->list (find-packages-by-name "guile" #f))
+          (map ->list (find-packages-by-name "guile" "2.2"))))
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (->list   (lambda (package)
+                     (list (inferior-package-name package)
+                           (inferior-package-version package)
+                           (inferior-package-location package))))
+         (lst1     (map ->list
+                        (lookup-inferior-packages inferior "guile")))
+         (lst2     (map ->list
+                        (lookup-inferior-packages inferior
+                                                  "guile" "2.2"))))
+    (close-inferior inferior)
+    (list lst1 lst2)))
+
+(test-assert "lookup-inferior-packages and eq?-ness"
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (lst1     (lookup-inferior-packages inferior "guile"))
+         (lst2     (lookup-inferior-packages inferior "guile")))
+    (close-inferior inferior)
+    (every eq? lst1 lst2)))
+
 (test-equal "inferior-package-derivation"
   (map derivation-file-name
        (list (package-derivation %store %bootstrap-guile "x86_64-linux")