ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

inferior: Add 'lookup-inferior-packages'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2018-09-15 14:50:14 +02:00
parent 9daf046c5d
commit e1a4ffdab5
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 70 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
guix/inferior.scm
View file

@ -22,7 +22,8 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
inferior-package-version
inferior-packages
lookup-inferior-packages
inferior-package-synopsis
inferior-package-description
inferior-package-home-page
@ -61,11 +65,13 @@ (define-module (guix inferior)
;; 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 @@ (define pipe
(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 @@ (define (write-inferior-package package port)
(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 @@ (define (inferior-packages inferior)
(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))

29
tests/inferior.scm
View file

@ -79,6 +79,35 @@ (define result
(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")