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

import: utils: 'recursive-import' returns packages in topological order.

Browse source 
* guix/import/utils.scm (topological-sort): New procedure.
(recursive-import): Rewrite to use it.
* tests/import-utils.scm ("recursive-import"): New test.
* guix/import/cran.scm (cran->guix-package): Always return two values.
* guix/scripts/import/cran.scm (guix-import-cran): Remove 'reverse' call
on 'cran-recursive-import' result.
* guix/scripts/import/crate.scm (guix-import-crate): Likewise.
* guix/scripts/import/elpa.scm (guix-import-elpa): Likewise.
* guix/scripts/import/gem.scm (guix-import-gem): Likewise.
* guix/scripts/import/hackage.scm (guix-import-hackage): Likewise.
* guix/scripts/import/opam.scm (guix-import-opam): Likewise.
* guix/scripts/import/pypi.scm (guix-import-pypi): Likewise.
* guix/scripts/import/stackage.scm (guix-import-stackage): Likewise.
* tests/gem.scm ("gem-recursive-import"): Change the order of package
expressions accordingly.
This commit is contained in:
Ludovic Courtès 2019-12-10 20:13:04 +01:00
parent 6c3021a840
commit ddd5915900
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
12 changed files with 104 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
guix/import/cran.scm
View file

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
@ -505,7 +505,7 @@ (define cran->guix-package
((bioconductor)
;; Retry import from CRAN
(cran->guix-package package-name 'cran))
(else #f)))))))
(else (values #f '()))))))))
(define* (cran-recursive-import package-name #:optional (repo 'cran))
(recursive-import package-name repo

82
guix/import/utils.scm
View file

@ -34,12 +34,14 @@ (define-module (guix import utils)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix download)
#:use-module (guix sets)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-41)
@ -377,40 +379,54 @@ (define (guix-name prefix name)
(chr (char-downcase chr)))
name)))
(define (topological-sort nodes
node-dependencies
node-name)
"Perform a breadth-first traversal of the graph rooted at NODES, a list of
nodes, and return the list of nodes sorted in topological order. Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
(let loop ((nodes nodes)
(result '())
(visited (set)))
(match nodes
(()
result)
((head . tail)
(if (set-contains? visited (node-name head))
(loop tail result visited)
(let ((dependencies (node-dependencies head)))
(loop (append dependencies tail)
(cons head result)
(set-insert (node-name head) visited))))))))
(define* (recursive-import package-name repo
#:key repo->guix-package guix-name
#:allow-other-keys)
"Generate a stream of package expressions for PACKAGE-NAME and all its
dependencies."
(define (exists? dependency)
(not (null? (find-packages-by-name (guix-name dependency)))))
(define initial-state (list #f (list package-name) (list)))
(define (step state)
(match state
((prev (next . rest) done)
(define (handle? dep)
(and
(not (equal? dep next))
(not (member dep done))
(not (exists? dep))))
(receive (package . dependencies) (repo->guix-package next repo)
(list
(if package package '()) ;; default #f on failure would interrupt
(if package
(lset-union equal? rest (filter handle? (car dependencies)))
rest)
(cons next done))))
((prev '() done)
(list #f '() done))))
"Return a stream of package expressions for PACKAGE-NAME and all its
dependencies, sorted in topological order. For each package,
call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression
and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package
name corresponding to the upstream name."
(define-record-type <node>
(make-node name package dependencies)
node?
(name node-name)
(package node-package)
(dependencies node-dependencies))
;; Generate a lazy stream of package expressions for all unknown
;; dependencies in the graph.
(stream-unfold
;; map: produce a stream element
(match-lambda ((latest queue done) latest))
;; predicate
(match-lambda ((latest queue done) latest))
;; generator: update the queue
step
;; initial state
(step initial-state)))
(define (exists? name)
(not (null? (find-packages-by-name (guix-name name)))))
(define (lookup-node name)
(receive (package dependencies) (repo->guix-package name repo)
(make-node name package dependencies)))
(list->stream ;TODO: remove streams
(map node-package
(topological-sort (list (lookup-node package-name))
(lambda (node)
(map lookup-node
(remove exists?
(node-dependencies node))))
node-name))))

7
guix/scripts/import/cran.scm
View file

@ -98,10 +98,9 @@ (define (parse-options)
(if (assoc-ref opts 'recursive)
;; Recursive import
(map package->definition
(reverse
(stream->list
(cran-recursive-import package-name
(or (assoc-ref opts 'repo) 'cran)))))
(stream->list
(cran-recursive-import package-name
(or (assoc-ref opts 'repo) 'cran))))
;; Single import
(let ((sexp (cran->guix-package package-name
(or (assoc-ref opts 'repo) 'cran))))

5
guix/scripts/import/crate.scm
View file

@ -101,9 +101,8 @@ (define-values (name version)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(crate-recursive-import name))))
(stream->list
(crate-recursive-import name)))
(let ((sexp (crate->guix-package name version)))
(unless sexp
(leave (G_ "failed to download meta-data for package '~a'~%")

7
guix/scripts/import/elpa.scm
View file

@ -101,10 +101,9 @@ (define (parse-options)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(elpa-recursive-import package-name
(or (assoc-ref opts 'repo) 'gnu)))))
(stream->list
(elpa-recursive-import package-name
(or (assoc-ref opts 'repo) 'gnu))))
(let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo))))
(unless sexp
(leave (G_ "failed to download package '~a'~%") package-name))

5
guix/scripts/import/gem.scm
View file

@ -95,9 +95,8 @@ (define (parse-options)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(gem-recursive-import package-name 'rubygems))))
(stream->list
(gem-recursive-import package-name 'rubygems)))
(let ((sexp (gem->guix-package package-name)))
(unless sexp
(leave (G_ "failed to download meta-data for package '~a'~%")

5
guix/scripts/import/hackage.scm
View file

@ -130,9 +130,8 @@ (define (run-importer package-name opts error-fn)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(apply hackage-recursive-import arguments))))
(stream->list
(apply hackage-recursive-import arguments)))
;; Single import
(apply hackage->guix-package arguments))))
(unless sexp (error-fn))

5
guix/scripts/import/opam.scm
View file

@ -94,9 +94,8 @@ (define (parse-options)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(opam-recursive-import package-name))))
(stream->list
(opam-recursive-import package-name)))
;; Single import
(let ((sexp (opam->guix-package package-name)))
(unless sexp

5
guix/scripts/import/pypi.scm
View file

@ -95,9 +95,8 @@ (define (parse-options)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(pypi-recursive-import package-name))))
(stream->list
(pypi-recursive-import package-name)))
;; Single import
(let ((sexp (pypi->guix-package package-name)))
(unless sexp

5
guix/scripts/import/stackage.scm
View file

@ -110,9 +110,8 @@ (define (run-importer package-name opts error-fn)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(apply stackage-recursive-import arguments))))
(stream->list
(apply stackage-recursive-import arguments)))
;; Single import
(apply stackage->guix-package arguments))))
(unless sexp (error-fn))

22
tests/gem.scm
View file

@ -123,22 +123,21 @@ (define test-bundler-json
(_ (error "Unexpected URL: " url)))))
(match (stream->list (gem-recursive-import "foo"))
((('package
('name "ruby-foo")
('name "ruby-bar")
('version "1.0.0")
('source
('origin
('method 'url-fetch)
('uri ('rubygems-uri "foo" 'version))
('uri ('rubygems-uri "bar" 'version))
('sha256
('base32
"1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
('build-system 'ruby-build-system)
('propagated-inputs
('quasiquote
(("bundler" ('unquote 'bundler))
("ruby-bar" ('unquote 'ruby-bar)))))
('synopsis "A cool gem")
('description "This package provides a cool gem")
(('"bundler" ('unquote 'bundler)))))
('synopsis "Another cool gem")
('description "Another cool gem")
('home-page "https://example.com")
('license ('list 'license:expat 'license:asl2.0)))
('package
@ -157,21 +156,22 @@ (define test-bundler-json
('home-page "https://bundler.io/")
('license 'license:expat))
('package
('name "ruby-bar")
('name "ruby-foo")
('version "1.0.0")
('source
('origin
('method 'url-fetch)
('uri ('rubygems-uri "bar" 'version))
('uri ('rubygems-uri "foo" 'version))
('sha256
('base32
"1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
('build-system 'ruby-build-system)
('propagated-inputs
('quasiquote
(('"bundler" ('unquote 'bundler)))))
('synopsis "Another cool gem")
('description "Another cool gem")
(("bundler" ('unquote 'bundler))
("ruby-bar" ('unquote 'ruby-bar)))))
('synopsis "A cool gem")
('description "This package provides a cool gem")
('home-page "https://example.com")
('license ('list 'license:expat 'license:asl2.0))))
#t)

25
tests/import-utils.scm
View file

@ -24,7 +24,9 @@ (define-module (test-import-utils)
#:use-module (guix packages)
#:use-module (guix build-system)
#:use-module (gnu packages)
#:use-module (srfi srfi-64))
#:use-module (srfi srfi-41)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
(test-begin "import-utils")
@ -41,6 +43,27 @@ (define-module (test-import-utils)
'license:lgpl2.0
(license->symbol license:lgpl2.0))
(test-equal "recursive-import"
'((package ;package expressions in topological order
(name "bar"))
(package
(name "foo")
(inputs `(("bar" ,bar)))))
(stream->list
(recursive-import "foo" 'repo
#:repo->guix-package
(match-lambda*
(("foo" 'repo)
(values '(package
(name "foo")
(inputs `(("bar" ,bar))))
'("bar")))
(("bar" 'repo)
(values '(package
(name "bar"))
'())))
#:guix-name identity)))
(test-assert "alist->package with simple source"
(let* ((meta '(("name" . "hello")
("version" . "2.10")