Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Tue, 18 Sep 2018 12:05:02 UTC
Severity: normal
Tags: patch
Done: ludo <at> gnu.org (Ludovic Courtès)
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: 32759 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [bug#32759] [PATCH 2/8] inferior: Add 'lookup-inferior-packages'. Date: Tue, 18 Sep 2018 14:06:34 +0200
* 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 5bef96488..81b71d0c7 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 817fcb6c6..791e30b17 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")
--
2.18.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.