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.
master
Ludovic Courtès
parent
9daf046c5d
commit
e1a4ffdab5
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue