TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

upstream: Replace 'input-changes' field by 'inputs'. 

Returning the expected list of inputs rather than changes relative to
the current package definition is less ambiguous and offers more
possibilities for further processing.

* guix/upstream.scm (<upstream-source>)[input-changes]: Remove.
[inputs]: New field.
(<upstream-input>): New record type.
* guix/upstream.scm (upstream-input-type-predicate)
(input-type-filter, upstream-source-regular-inputs)
(upstream-source-native-inputs, upstream-source-propagated-inputs): New
procedures.
(changed-inputs): Expect an <upstream-source> as its second argument.
Adjust accordingly.
* guix/import/pypi.scm (distribution-sha256): New procedure.
(maybe-inputs): Expect a list of <upstream-input>.
(compute-inputs): Rewrite to return a list of <upstream-input>.
(pypi-package-inputs, pypi-package->upstream-source): New procedures.
(make-pypi-sexp): Use it.
* guix/import/stackage.scm (latest-lts-release): Define 'cabal'.
Replace 'input-changes' field by 'inputs'.
* guix/scripts/refresh.scm (update-package): Use 'changed-inputs'
instead of 'upstream-source-input-changes'.
* tests/cran.scm ("description->package"): Adjust order of inputs.
* tests/pypi.scm (default-sha256, default-sha256/base32): New variables.
(foo-json): Add 'digests' entry.
("pypi->guix-package, no wheel"): Check HASH against DEFAULT-SHA256/BASE32.
("pypi->guix-package, wheels"): Likewise.
("pypi->guix-package, no usable requirement file."): Likewise.
("pypi->guix-package, package name contains \"-\" followed by digits"):
Likewise.
("package-latest-release"): New test.
* tests/upstream.scm (test-package-sexp): Remove.
("changed-inputs returns no changes"): Rewrite to use <upstream-source>.
(test-new-package-sexp): Remove.
("changed-inputs returns changes to plain input list"): Rewrite.
("changed-inputs returns changes to all plain input lists"): Likewise.
("changed-inputs returns changes to labelled input list")
("changed-inputs returns changes to all labelled input lists"): Remove.
* guix/import/cran.scm (maybe-inputs): Expect PACKAGE-INPUTS to be a
list of <upstream-input>.
(source-dir->dependencies): Return a list of <upstream-input>.
(vignette-builders): Likewise.
(uri-helper, cran-package-source-url)
(cran-package-propagated-inputs, cran-package-inputs): New procedures.
(description->package): Use them instead of local definitions.
(latest-cran-release): Replace 'input-changes' field by 'inputs'.
(latest-bioconductor-release): Likewise.
(format-inputs): Remove.
* guix/import/hackage.scm (cabal-package-inputs): New procedure.
(hackage-module->sexp): Use it.
[maybe-inputs]: Expect a list of <upstream-input>.
This commit is contained in:
Ludovic Courtès 2023-05-15 22:37:25 +02:00
parent db10a4a2ae
commit e6223017d9
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
8 changed files with 510 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
guix/import/cran.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@ -164,24 +164,16 @@
rest))))))) rest)))))))
(fold parse '() lines))) (fold parse '() lines)))
(define (format-inputs names) (define* (maybe-inputs package-inputs #:optional (input-type 'inputs))
"Generate a sorted list of package inputs from a list of package NAMES."
(map (lambda (name)
(case (%input-style)
((specification)
`(specification->package ,name))
(else
(string->symbol name))))
(sort names string-ci<?)))
(define* (maybe-inputs package-inputs #:optional (type 'inputs))
"Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
package definition." package definition."
(match package-inputs (match package-inputs
(() (()
'()) '())
((package-inputs ...) ((package-inputs ...)
`((,type (list ,@(format-inputs package-inputs))))))) `((,input-type (list ,@(map (compose string->symbol
upstream-input-downstream-name)
package-inputs)))))))
(define %cran-url "https://cran.r-project.org/web/packages/") (define %cran-url "https://cran.r-project.org/web/packages/")
(define %cran-canonical-url "https://cran.r-project.org/package=") (define %cran-canonical-url "https://cran.r-project.org/package=")
@ -520,14 +512,29 @@ the pkg-config tool."
"(Makevars.*|configure.*)")) "(Makevars.*|configure.*)"))
(define (source-dir->dependencies dir) (define (source-dir->dependencies dir)
"Guess dependencies of R package source in DIR and return two values: a list "Guess dependencies of R package source in DIR and return a list of
of package names for INPUTS and another list of names of NATIVE-INPUTS." <upstream-input> corresponding to the dependencies guessed from source files
(values in DIR."
(needed-libraries-in-directory dir) (define (native name)
(append (upstream-input
(if (directory-needs-esbuild? dir) '("esbuild") '()) (name name)
(if (directory-needs-pkg-config? dir) '("pkg-config") '()) (downstream-name name)
(if (directory-needs-fortran? dir) '("gfortran") '())))) (type 'native)))
(append (map (lambda (name)
(upstream-input
(name name)
(downstream-name (cran-guix-name name))))
(needed-libraries-in-directory dir))
(if (directory-needs-esbuild? dir)
(list (native "esbuild"))
'())
(if (directory-needs-pkg-config? dir)
(list (native "pkg-config"))
'())
(if (directory-needs-fortran? dir)
(list (native "gfortran"))
'())))
(define (source->dependencies source tarball?) (define (source->dependencies source tarball?)
"SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated "SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated
@ -541,7 +548,79 @@ by TARBALL?"
(source-dir->dependencies source))) (source-dir->dependencies source)))
(define (vignette-builders meta) (define (vignette-builders meta)
(map cran-guix-name (listify meta "VignetteBuilder"))) (map (lambda (name)
(upstream-input
(name name)
(downstream-name (cran-guix-name name))
(type 'native)))
(listify meta "VignetteBuilder")))
(define (uri-helper repository)
(match repository
('cran cran-uri)
('bioconductor bioconductor-uri)
('git #f)
('hg #f)))
(define (cran-package-source-url meta repository)
"Return the URL of the source code referred to by META, a package in
REPOSITORY."
(case repository
((git) (assoc-ref meta 'git))
((hg) (assoc-ref meta 'hg))
(else
(match (apply (uri-helper repository)
(assoc-ref meta "Package")
(assoc-ref meta "Version")
(case repository
((bioconductor)
(list (assoc-ref meta 'bioconductor-type)))
(else '())))
((urls ...) urls)
((? string? url) url)
(_ #f)))))
(define (cran-package-propagated-inputs meta)
"Return the list of <upstream-input> derived from dependency information in
META."
(filter-map (lambda (name)
(and (not (member name
(append default-r-packages invalid-packages)))
(upstream-input
(name name)
(downstream-name (cran-guix-name name))
(type 'propagated))))
(lset-union equal?
(listify meta "Imports")
(listify meta "LinkingTo")
(delete "R" (listify meta "Depends")))))
(define* (cran-package-inputs meta repository
#:key (download-source download))
"Return the list of <upstream-input> corresponding to all the dependencies
of META, a package in REPOSITORY."
(let* ((url (cran-package-source-url meta repository))
(source (download-source url
#:method
(cond ((assoc-ref meta 'git) 'git)
((assoc-ref meta 'hg) 'hg)
(else #f))))
(tarball? (not (or (assoc-ref meta 'git)
(assoc-ref meta 'hg)))))
(sort (append (source->dependencies source tarball?)
(filter-map (lambda (name)
(and (not (member name invalid-packages))
(upstream-input
(name name)
(downstream-name
(transform-sysname name)))))
(map string-downcase
(listify meta "SystemRequirements")))
(cran-package-propagated-inputs meta)
(vignette-builders meta))
(lambda (input1 input2)
(string<? (upstream-input-downstream-name input1)
(upstream-input-downstream-name input2))))))
(define* (description->package repository meta #:key (license-prefix identity) (define* (description->package repository meta #:key (license-prefix identity)
(download-source download)) (download-source download))
@ -556,11 +635,6 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
((cran) %cran-canonical-url) ((cran) %cran-canonical-url)
((bioconductor) %bioconductor-url) ((bioconductor) %bioconductor-url)
((git) #f))) ((git) #f)))
(uri-helper (case repository
((cran) cran-uri)
((bioconductor) bioconductor-uri)
((git) #f)
((hg) #f)))
(name (assoc-ref meta "Package")) (name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title")) (synopsis (assoc-ref meta "Title"))
(version (assoc-ref meta "Version")) (version (assoc-ref meta "Version"))
@ -572,40 +646,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(else (match (listify meta "URL") (else (match (listify meta "URL")
((url rest ...) url) ((url rest ...) url)
(_ (string-append canonical-url-base name)))))) (_ (string-append canonical-url-base name))))))
(source-url (case repository (source-url (cran-package-source-url meta repository))
((git) (assoc-ref meta 'git))
((hg) (assoc-ref meta 'hg))
(else
(match (apply uri-helper name version
(case repository
((bioconductor)
(list (assoc-ref meta 'bioconductor-type)))
(else '())))
((urls ...) urls)
((? string? url) url)
(_ #f)))))
(git? (if (assoc-ref meta 'git) #true #false)) (git? (if (assoc-ref meta 'git) #true #false))
(hg? (if (assoc-ref meta 'hg) #true #false)) (hg? (if (assoc-ref meta 'hg) #true #false))
(source (download-source source-url #:method (cond (source (download-source source-url #:method (cond
(git? 'git) (git? 'git)
(hg? 'hg) (hg? 'hg)
(else #f)))) (else #f))))
(tarball? (not (or git? hg?))) (uri-helper (uri-helper repository))
(source-inputs source-native-inputs (inputs (cran-package-inputs meta repository
(source->dependencies source tarball?)) #:download-source download-source))
(sysdepends (append
source-inputs
(filter (lambda (name)
(not (member name invalid-packages)))
(map string-downcase (listify meta "SystemRequirements")))))
(propagate (filter (lambda (name)
(not (member name (append default-r-packages
invalid-packages))))
(lset-union equal?
(listify meta "Imports")
(listify meta "LinkingTo")
(delete "R"
(listify meta "Depends")))))
(package (package
`(package `(package
(name ,(cran-guix-name name)) (name ,(cran-guix-name name))
@ -651,12 +701,18 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
`((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
'()) '())
(build-system r-build-system) (build-system r-build-system)
,@(maybe-inputs (map transform-sysname sysdepends))
,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular)
,@(maybe-inputs inputs)
`(,@source-native-inputs 'inputs)
,@(vignette-builders meta)) ,@(maybe-inputs (filter (upstream-input-type-predicate
'native-inputs) 'propagated)
inputs)
'propagated-inputs)
,@(maybe-inputs (filter (upstream-input-type-predicate 'native)
inputs)
'native-inputs)
(home-page ,(if (string-null? home-page) (home-page ,(if (string-null? home-page)
(string-append base-url name) (string-append base-url name)
home-page)) home-page))
@ -675,7 +731,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(revision "1")) (revision "1"))
,package)) ,package))
(else package)) (else package))
propagate))) (filter-map (lambda (input)
(and (eq? 'propagated (upstream-input-type input))
(upstream-input-name input)))
inputs))))
(define cran->guix-package (define cran->guix-package
(memoize (memoize
@ -760,9 +819,7 @@ s-expression corresponding to that package, or #f on failure."
(package (package-name pkg)) (package (package-name pkg))
(version version) (version version)
(urls (cran-uri upstream-name version)) (urls (cran-uri upstream-name version))
(input-changes (inputs (cran-package-inputs meta 'cran))))))
(changed-inputs pkg
(description->package 'cran meta)))))))
(define* (latest-bioconductor-release pkg #:key (version #f)) (define* (latest-bioconductor-release pkg #:key (version #f))
"Return an <upstream-source> for the latest release of the package PKG." "Return an <upstream-source> for the latest release of the package PKG."
@ -784,10 +841,9 @@ s-expression corresponding to that package, or #f on failure."
(package (package-name pkg)) (package (package-name pkg))
(version latest-version) (version latest-version)
(urls (bioconductor-uri upstream-name latest-version)) (urls (bioconductor-uri upstream-name latest-version))
(input-changes (inputs
(changed-inputs (let ((meta (fetch-description 'bioconductor upstream-name)))
pkg (cran-package-inputs meta 'bioconductor))))))
(cran->guix-package upstream-name #:repo 'bioconductor))))))
(define (cran-package? package) (define (cran-package? package)
"Return true if PACKAGE is an R package from CRAN." "Return true if PACKAGE is an R package from CRAN."

90
guix/import/hackage.scm
View File

@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -56,7 +57,9 @@
hackage-fetch hackage-fetch
hackage-source-url hackage-source-url
hackage-cabal-url hackage-cabal-url
hackage-package?)) hackage-package?
cabal-package-inputs))
(define ghc-standard-libraries (define ghc-standard-libraries
;; List of libraries distributed with ghc (as of 8.10.7). ;; List of libraries distributed with ghc (as of 8.10.7).
@ -224,27 +227,12 @@ references to itself."
(filter (lambda (d) (not (member (string-downcase d) ignored-dependencies))) (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies)))
dependencies))) dependencies)))
(define* (hackage-module->sexp cabal cabal-hash (define* (cabal-package-inputs cabal #:key (include-test-dependencies? #t))
#:key (include-test-dependencies? #t)) "Return the list of <upstream-input> for CABAL representing its
"Return the `package' S-expression for a Cabal package. CABAL is the dependencies."
representation of a Cabal file as produced by 'read-cabal'. CABAL-HASH is (define own-names
the hash of the Cabal file." (cons (cabal-package-name cabal)
(filter-map cabal-library-name (cabal-package-library cabal))))
(define name
(cabal-package-name cabal))
(define version
(cabal-package-version cabal))
(define revision
(cabal-package-revision cabal))
(define source-url
(hackage-source-url name version))
(define own-names (cons (cabal-package-name cabal)
(filter (lambda (x) (not (eqv? x #f)))
(map cabal-library-name (cabal-package-library cabal)))))
(define hackage-dependencies (define hackage-dependencies
(filter-dependencies (cabal-dependencies->names cabal) own-names)) (filter-dependencies (cabal-dependencies->names cabal) own-names))
@ -261,22 +249,54 @@ the hash of the Cabal file."
hackage-dependencies)) hackage-dependencies))
(define dependencies (define dependencies
(map string->symbol (map (lambda (name)
(map hackage-name->package-name (upstream-input
hackage-dependencies))) (name name)
(downstream-name (hackage-name->package-name name))
(type 'regular)))
hackage-dependencies))
(define native-dependencies (define native-dependencies
(map string->symbol (map (lambda (name)
(map hackage-name->package-name (upstream-input
hackage-native-dependencies))) (name name)
(downstream-name (hackage-name->package-name name))
(type 'native)))
hackage-native-dependencies))
(append dependencies native-dependencies))
(define* (hackage-module->sexp cabal cabal-hash
#:key (include-test-dependencies? #t))
"Return the `package' S-expression for a Cabal package. CABAL is the
representation of a Cabal file as produced by 'read-cabal'. CABAL-HASH is
the hash of the Cabal file."
(define name
(cabal-package-name cabal))
(define version
(cabal-package-version cabal))
(define revision
(cabal-package-revision cabal))
(define source-url
(hackage-source-url name version))
(define inputs
(cabal-package-inputs cabal
#:include-test-dependencies?
include-test-dependencies?))
(define (maybe-inputs input-type inputs) (define (maybe-inputs input-type inputs)
(match inputs (match inputs
(() (()
'()) '())
((inputs ...) ((inputs ...)
(list (list input-type (list (list input-type
`(list ,@inputs)))))) `(list ,@(map (compose string->symbol
upstream-input-downstream-name)
inputs)))))))
(define (maybe-arguments) (define (maybe-arguments)
(match (append (if (not include-test-dependencies?) (match (append (if (not include-test-dependencies?)
@ -304,14 +324,18 @@ the hash of the Cabal file."
"failed to download tar archive"))))) "failed to download tar archive")))))
(build-system haskell-build-system) (build-system haskell-build-system)
(properties '((upstream-name . ,name))) (properties '((upstream-name . ,name)))
,@(maybe-inputs 'inputs dependencies) ,@(maybe-inputs 'inputs
,@(maybe-inputs 'native-inputs native-dependencies) (filter (upstream-input-type-predicate 'regular)
inputs))
,@(maybe-inputs 'native-inputs
(filter (upstream-input-type-predicate 'native)
inputs))
,@(maybe-arguments) ,@(maybe-arguments)
(home-page ,(cabal-package-home-page cabal)) (home-page ,(cabal-package-home-page cabal))
(synopsis ,(cabal-package-synopsis cabal)) (synopsis ,(cabal-package-synopsis cabal))
(description ,(beautify-description (cabal-package-description cabal))) (description ,(beautify-description (cabal-package-description cabal)))
(license ,(string->license (cabal-package-license cabal)))) (license ,(string->license (cabal-package-license cabal))))
(append hackage-dependencies hackage-native-dependencies)))) inputs)))
(define* (hackage->guix-package package-name #:key (define* (hackage->guix-package package-name #:key
(include-test-dependencies? #t) (include-test-dependencies? #t)

205
guix/import/pypi.scm
View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@ -33,12 +33,16 @@
(define-module (guix import pypi) (define-module (guix import pypi)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 receive)
#:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:autoload (gcrypt hash) (port-sha256)
#:autoload (guix base16) (base16-string->bytevector)
#:autoload (guix base32) (bytevector->nix-base32-string)
#:autoload (guix http-client) (http-fetch)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
@ -126,6 +130,12 @@
(python-version distribution-package-python-version (python-version distribution-package-python-version
"python_version")) "python_version"))
(define (distribution-sha256 distribution)
"Return the SHA256 hash of DISTRIBUTION as a bytevector, or #f."
(match (assoc-ref (distribution-digests distribution) "sha256")
(#f #f)
(str (base16-string->bytevector str))))
(define (pypi-fetch name) (define (pypi-fetch name)
"Return a <pypi-project> record for package NAME, or #f on failure." "Return a <pypi-project> record for package NAME, or #f on failure."
(and=> (json-fetch (string-append (%pypi-base-url) name "/json")) (and=> (json-fetch (string-append (%pypi-base-url) name "/json"))
@ -198,7 +208,9 @@ the input field."
(() (()
'()) '())
((package-inputs ...) ((package-inputs ...)
`((,input-type (list ,@package-inputs)))))) `((,input-type (list ,@(map (compose string->symbol
upstream-input-downstream-name)
package-inputs)))))))
(define %requirement-name-regexp (define %requirement-name-regexp
;; Regexp to match the requirement name in a requirement specification. ;; Regexp to match the requirement name in a requirement specification.
@ -409,23 +421,36 @@ cannot determine package dependencies from source archive: ~a~%")
(define (compute-inputs source-url wheel-url archive) (define (compute-inputs source-url wheel-url archive)
"Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return
a pair of lists, each consisting of a list of name/variable pairs, for the the corresponding list of <upstream-input> records."
propagated inputs and the native inputs, respectively. Also (define (requirements->upstream-inputs deps type)
return the unaltered list of upstream dependency names." (filter-map (match-lambda
("argparse" #f)
(define (strip-argparse deps) (name (upstream-input
(remove (cut string=? "argparse" <>) deps)) (name name)
(downstream-name (python->package-name name))
(define (requirement->package-name/sort deps) (type type))))
(map string->symbol (sort deps string-ci<?)))
(sort (map python->package-name deps) string-ci<?)))
(define process-requirements
(compose requirement->package-name/sort strip-argparse))
;; TODO: Record version number ranges in <upstream-input>.
(let ((dependencies (guess-requirements source-url wheel-url archive))) (let ((dependencies (guess-requirements source-url wheel-url archive)))
(values (map process-requirements dependencies) (match dependencies
(concatenate dependencies)))) ((propagated native)
(append (requirements->upstream-inputs propagated 'propagated)
(requirements->upstream-inputs native 'native))))))
(define* (pypi-package-inputs pypi-package #:optional version)
"Return the list of <upstream-input> for PYPI-PACKAGE. This procedure
downloads the source and possibly the wheel of PYPI-PACKAGE."
(let* ((info (pypi-project-info pypi-package))
(version (or version (project-info-version info)))
(dist (source-release pypi-package version))
(source-url (distribution-url dist))
(wheel-url (and=> (wheel-release pypi-package version)
distribution-url)))
(call-with-temporary-output-file
(lambda (archive port)
(and (url-fetch source-url archive)
(compute-inputs source-url wheel-url archive))))))
(define (find-project-url name pypi-url) (define (find-project-url name pypi-url)
"Try different project name substitution until the result is found in "Try different project name substitution until the result is found in
@ -445,52 +470,85 @@ pypi-uri declaration in the generated package. You may need to replace ~s with
a substring of the PyPI URI that identifies the package.") pypi-url name)) a substring of the PyPI URI that identifies the package.") pypi-url name))
name))) name)))
(define (make-pypi-sexp name version source-url wheel-url home-page synopsis (define* (pypi-package->upstream-source pypi-package #:optional version)
description license) "Return the upstream source for the given VERSION of PYPI-PACKAGE, a
"Return the `package' s-expression for a python package with the given NAME, <pypi-project> record. If VERSION is omitted or #f, use the latest version."
VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (let* ((info (pypi-project-info pypi-package))
(version (or version (project-info-version info)))
(dist (source-release pypi-package version))
(source-url (distribution-url dist))
(wheel-url (and=> (wheel-release pypi-package version)
distribution-url)))
(let ((extra-inputs (if (string-suffix? ".zip" source-url)
(list (upstream-input
(name "zip")
(downstream-name "zip")
(type 'native)))
'())))
(upstream-source
(urls (list source-url))
(signature-urls
(if (distribution-has-signature? dist)
(list (string-append source-url ".asc"))
#f))
(inputs (append (pypi-package-inputs pypi-package)
extra-inputs))
(package (project-info-name info))
(version version)))))
(define* (make-pypi-sexp pypi-package
#:optional (version (latest-version pypi-package)))
"Return the `package' s-expression the given VERSION of PYPI-PACKAGE, a
<pypi-project> record."
(define (maybe-upstream-name name) (define (maybe-upstream-name name)
(if (string-match ".*\\-[0-9]+" name) (if (string-match ".*\\-[0-9]+" name)
`((properties ,`'(("upstream-name" . ,name)))) `((properties ,`'(("upstream-name" . ,name))))
'())) '()))
(call-with-temporary-output-file (let* ((info (pypi-project-info pypi-package))
(lambda (temp port) (name (project-info-name info))
(and (url-fetch source-url temp) (source-url (and=> (source-release pypi-package version)
(receive (guix-dependencies upstream-dependencies) distribution-url))
(compute-inputs source-url wheel-url temp) (sha256 (and=> (source-release pypi-package version)
(match guix-dependencies distribution-sha256))
((required-inputs native-inputs) (source (pypi-package->upstream-source pypi-package version)))
(when (string-suffix? ".zip" source-url) (values
(set! native-inputs (cons 'unzip native-inputs))) `(package
(values (name ,(python->package-name name))
`(package (version ,version)
(name ,(python->package-name name)) (source
(version ,version) (origin
(source (method url-fetch)
(origin (uri (pypi-uri
(method url-fetch) ,(find-project-url name source-url)
(uri (pypi-uri version
,(find-project-url name source-url) ;; Some packages have been released as `.zip`
version ;; instead of the more common `.tar.gz`. For
;; Some packages have been released as `.zip` ;; example, see "path-and-address".
;; instead of the more common `.tar.gz`. For ,@(if (string-suffix? ".zip" source-url)
;; example, see "path-and-address". '(".zip")
,@(if (string-suffix? ".zip" source-url) '())))
'(".zip") (sha256 (base32
'()))) ,(and=> (or sha256
(sha256 (let* ((port (http-fetch source-url))
(base32 (hash (port-sha256 port)))
,(guix-hash-url temp))))) (close-port port)
,@(maybe-upstream-name name) hash))
(build-system pyproject-build-system) bytevector->nix-base32-string)))))
,@(maybe-inputs required-inputs 'propagated-inputs) ,@(maybe-upstream-name name)
,@(maybe-inputs native-inputs 'native-inputs) (build-system pyproject-build-system)
(home-page ,home-page) ,@(maybe-inputs (upstream-source-propagated-inputs source)
(synopsis ,synopsis) 'propagated-inputs)
(description ,(beautify-description description)) ,@(maybe-inputs (upstream-source-native-inputs source)
(license ,(license->symbol license))) 'native-inputs)
upstream-dependencies)))))))) (home-page ,(project-info-home-page info))
(synopsis ,(project-info-summary info))
(description ,(beautify-description
(project-info-summary info)))
(license ,(license->symbol
(string->license
(project-info-license info)))))
(map upstream-input-name (upstream-source-inputs source)))))
(define pypi->guix-package (define pypi->guix-package
(memoize (memoize
@ -520,16 +578,7 @@ package is available on PyPI, but only as a \"wheel\" containing binaries, not
source. To build it from source, refer to the upstream repository at source. To build it from source, refer to the upstream repository at
@uref{~a}.") @uref{~a}.")
url)))))))))))) url))))))))))))
(make-pypi-sexp (project-info-name info) version (make-pypi-sexp project version))
(and=> (source-release project version)
distribution-url)
(and=> (wheel-release project version)
distribution-url)
(project-info-home-page info)
(project-info-summary info)
(project-info-summary info)
(string->license
(project-info-license info))))
(values #f '())))))) (values #f '()))))))
(define* (pypi-recursive-import package-name #:optional version) (define* (pypi-recursive-import package-name #:optional version)
@ -566,21 +615,7 @@ include a VERSION string to fetch a specific version."
(pypi-package (pypi-fetch pypi-name))) (pypi-package (pypi-fetch pypi-name)))
(and pypi-package (and pypi-package
(guard (c ((missing-source-error? c) #f)) (guard (c ((missing-source-error? c) #f))
(let* ((info (pypi-project-info pypi-package)) (pypi-package->upstream-source pypi-package version)))))
(version (or version (project-info-version info)))
(dist (source-release pypi-package version))
(url (distribution-url dist)))
(upstream-source
(urls (list url))
(signature-urls
(if (distribution-has-signature? dist)
(list (string-append url ".asc"))
#f))
(input-changes
(changed-inputs package
(pypi->guix-package pypi-name #:version version)))
(package (package-name package))
(version version)))))))
(define %pypi-updater (define %pypi-updater
(upstream-updater (upstream-updater

9
guix/import/stackage.scm
View File

@ -29,6 +29,7 @@
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (guix import json) #:use-module (guix import json)
#:use-module (guix import hackage) #:use-module (guix import hackage)
#:autoload (guix import cabal) (eval-cabal)
#:use-module (guix import utils) #:use-module (guix import utils)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix packages) #:use-module (guix packages)
@ -157,15 +158,13 @@ PACKAGE or #f if the package is not included in the Stackage LTS release."
(warning (G_ "failed to parse ~a~%") (warning (G_ "failed to parse ~a~%")
(hackage-cabal-url hackage-name)) (hackage-cabal-url hackage-name))
#f) #f)
(_ (let ((url (hackage-source-url hackage-name version))) (_ (let ((url (hackage-source-url hackage-name version))
(cabal (eval-cabal (hackage-fetch hackage-name) '())))
(upstream-source (upstream-source
(package (package-name pkg)) (package (package-name pkg))
(version version) (version version)
(urls (list url)) (urls (list url))
(input-changes (inputs (cabal-package-inputs cabal))))))))))
(changed-inputs
pkg
(stackage->guix-package hackage-name #:packages (packages))))))))))))
(define (stackage-lts-package? package) (define (stackage-lts-package? package)
"Return whether PACKAGE is available on the default Stackage LTS release." "Return whether PACKAGE is available on the default Stackage LTS release."

4
guix/scripts/refresh.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@ -404,7 +404,7 @@ warn about packages that have no matching updater."
(('remove 'propagated) (('remove 'propagated)
(info loc (G_ "~a: consider removing this propagated input: ~a~%") (info loc (G_ "~a: consider removing this propagated input: ~a~%")
name change-name)))) name change-name))))
(upstream-source-input-changes source)) (changed-inputs package source))
(let ((hash (file-hash* output))) (let ((hash (file-hash* output)))
(update-package-source package source hash))) (update-package-source package source hash)))
(warning (G_ "~a: version ~a could not be \ (warning (G_ "~a: version ~a could not be \

163
guix/upstream.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@ -55,7 +55,20 @@
upstream-source-urls upstream-source-urls
upstream-source-signature-urls upstream-source-signature-urls
upstream-source-archive-types upstream-source-archive-types
upstream-source-input-changes upstream-source-inputs
upstream-input-type-predicate
upstream-source-regular-inputs
upstream-source-native-inputs
upstream-source-propagated-inputs
upstream-input
upstream-input?
upstream-input-name
upstream-input-downstream-name
upstream-input-type
upstream-input-min-version
upstream-input-max-version
url-predicate url-predicate
url-prefix-predicate url-prefix-predicate
@ -102,8 +115,40 @@
(urls upstream-source-urls) ;list of strings|git-reference (urls upstream-source-urls) ;list of strings|git-reference
(signature-urls upstream-source-signature-urls ;#f | list of strings (signature-urls upstream-source-signature-urls ;#f | list of strings
(default #f)) (default #f))
(input-changes upstream-source-input-changes (inputs upstream-source-inputs ;#f | list of <upstream-input>
(default '()) (thunked))) (delayed) (default #f))) ;delayed because optional and costly
;; Representation of a dependency as expressed by upstream.
(define-record-type* <upstream-input>
upstream-input make-upstream-input
upstream-input?
(name upstream-input-name) ;upstream package name
(downstream-name upstream-input-downstream-name) ;Guix package name
(type upstream-input-type ;'regular | 'native | 'propagated
(default 'regular))
(min-version upstream-input-min-version
(default 'any))
(max-version upstream-input-max-version
(default 'any)))
(define (upstream-input-type-predicate type)
"Return a predicate that returns true when passed an <upstream-input> record
of the given TYPE (a symbol such as 'propagated)."
(lambda (source)
(eq? type (upstream-input-type source))))
(define (input-type-filter type)
"Return a procedure that, given an <upstream-source>, returns the subset of
its inputs that have the given TYPE (a symbol such as 'native)."
(lambda (source)
"Return the subset of inputs of SOURCE that have the given TYPE."
(filter (lambda (input)
(eq? type (upstream-input-type input)))
(upstream-source-inputs source))))
(define upstream-source-regular-inputs (input-type-filter 'regular))
(define upstream-source-native-inputs (input-type-filter 'native))
(define upstream-source-propagated-inputs (input-type-filter 'propagated))
;; Representation of an upstream input change. ;; Representation of an upstream input change.
(define-record-type* <upstream-input-change> (define-record-type* <upstream-input-change>
@ -113,67 +158,55 @@
(type upstream-input-change-type) ;symbol: regular | native | propagated (type upstream-input-change-type) ;symbol: regular | native | propagated
(action upstream-input-change-action)) ;symbol: add | remove (action upstream-input-change-action)) ;symbol: add | remove
(define (changed-inputs package package-sexp) (define (changed-inputs package source)
"Return a list of input changes for PACKAGE based on the newly imported "Return a list of input changes for PACKAGE compared to the 'inputs' field
S-expression PACKAGE-SEXP." of SOURCE, an <upstream-source> record."
(match package-sexp (define input->name
((and expr ('package fields ...)) (match-lambda
(let* ((input->name (match-lambda ((name pkg . out) name))) ((label (? package? pkg) . out) (package-name pkg))
(new-regular (_ #f)))
(match expr
((path *** ('inputs (if (upstream-source-inputs source)
('quasiquote ((label ('unquote sym)) ...)))) label) (let* ((new-regular (map upstream-input-downstream-name
((path *** ('inputs (upstream-source-regular-inputs source)))
('list sym ...))) (map symbol->string sym)) (new-native (map upstream-input-downstream-name
(_ '()))) (upstream-source-native-inputs source)))
(new-native (new-propagated (map upstream-input-downstream-name
(match expr (upstream-source-propagated-inputs source)))
((path *** ('native-inputs (current-regular
('quasiquote ((label ('unquote sym)) ...)))) label) (filter-map input->name (package-inputs package)))
((path *** ('native-inputs (current-native
('list sym ...))) (map symbol->string sym)) (filter-map input->name (package-native-inputs package)))
(_ '()))) (current-propagated
(new-propagated (filter-map input->name (package-propagated-inputs package))))
(match expr (append-map
((path *** ('propagated-inputs (match-lambda
('quasiquote ((label ('unquote sym)) ...)))) label) ((action type names)
((path *** ('propagated-inputs (map (lambda (name)
('list sym ...))) (map symbol->string sym)) (upstream-input-change
(_ '()))) (name name)
(current-regular (type type)
(map input->name (package-inputs package))) (action action)))
(current-native names)))
(map input->name (package-native-inputs package))) `((add regular
(current-propagated ,(lset-difference equal?
(map input->name (package-propagated-inputs package)))) new-regular current-regular))
(append-map (remove regular
(match-lambda ,(lset-difference equal?
((action type names) current-regular new-regular))
(map (lambda (name) (add native
(upstream-input-change ,(lset-difference equal?
(name name) new-native current-native))
(type type) (remove native
(action action))) ,(lset-difference equal?
names))) current-native new-native))
`((add regular (add propagated
,(lset-difference equal? ,(lset-difference equal?
new-regular current-regular)) new-propagated current-propagated))
(remove regular (remove propagated
,(lset-difference equal? ,(lset-difference equal?
current-regular new-regular)) current-propagated new-propagated)))))
(add native '()))
,(lset-difference equal?
new-native current-native))
(remove native
,(lset-difference equal?
current-native new-native))
(add propagated
,(lset-difference equal?
new-propagated current-propagated))
(remove propagated
,(lset-difference equal?
current-propagated new-propagated))))))
(_ '())))
(define* (url-predicate matching-url?) (define* (url-predicate matching-url?)
"Return a predicate that returns true when passed a package whose source is "Return a predicate that returns true when passed a package whose source is

62
tests/pypi.scm
View File

@ -25,9 +25,12 @@
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module ((guix base16) #:select (base16-string->bytevector))
#:use-module (guix upstream)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix tests http) #:use-module (guix tests http)
#:use-module ((guix download) #:select (url-fetch))
#:use-module (guix build-system python) #:use-module (guix build-system python)
#:use-module ((guix build utils) #:use-module ((guix build utils)
#:select (delete-file-recursively #:select (delete-file-recursively
@ -43,6 +46,12 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 optargs)) #:use-module (ice-9 optargs))
(define default-sha256
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
(define default-sha256/base32
(bytevector->nix-base32-string
(base16-string->bytevector default-sha256)))
(define* (foo-json #:key (name "foo") (name-in-url #f)) (define* (foo-json #:key (name "foo") (name-in-url #f))
"Create a JSON description of an example pypi package, named @var{name}, "Create a JSON description of an example pypi package, named @var{name},
optionally using a different @var{name in its URL}." optionally using a different @var{name in its URL}."
@ -65,7 +74,8 @@ optionally using a different @var{name in its URL}."
((url . ,(format #f "~a/~a-1.0.0.tar.gz" ((url . ,(format #f "~a/~a-1.0.0.tar.gz"
(%local-url #:path "") (%local-url #:path "")
(or name-in-url name))) (or name-in-url name)))
(packagetype . "sdist")) (packagetype . "sdist")
(digests . (("sha256" . ,default-sha256))))
((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl" ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl"
(%local-url #:path "") (%local-url #:path "")
(or name-in-url name))) (or name-in-url name)))
@ -308,9 +318,7 @@ files specified by SPECS. Return its file name."
('synopsis "summary") ('synopsis "summary")
('description "summary") ('description "summary")
('license 'license:lgpl2.0)) ('license 'license:lgpl2.0))
(and (string=? (bytevector->nix-base32-string (and (string=? default-sha256/base32 hash)
(file-sha256 tarball))
hash)
(equal? (pypi->guix-package "foo" #:version "1.0.0") (equal? (pypi->guix-package "foo" #:version "1.0.0")
(pypi->guix-package "foo")) (pypi->guix-package "foo"))
(guard (c ((error? c) #t)) (guard (c ((error? c) #t))
@ -352,8 +360,7 @@ to make sure we're testing wheels"))))
('synopsis "summary") ('synopsis "summary")
('description "summary") ('description "summary")
('license 'license:lgpl2.0)) ('license 'license:lgpl2.0))
(string=? (bytevector->nix-base32-string (file-sha256 tarball)) (string=? default-sha256/base32 hash))
hash))
(x (x
(pk 'fail x #f)))))) (pk 'fail x #f))))))
@ -382,8 +389,7 @@ to make sure we're testing wheels"))))
('synopsis "summary") ('synopsis "summary")
('description "summary") ('description "summary")
('license 'license:lgpl2.0)) ('license 'license:lgpl2.0))
(string=? (bytevector->nix-base32-string (file-sha256 tarball)) (string=? default-sha256/base32 hash))
hash))
(x (x
(pk 'fail x #f)))))) (pk 'fail x #f))))))
@ -414,11 +420,47 @@ to make sure we're testing wheels"))))
('synopsis "summary") ('synopsis "summary")
('description "summary") ('description "summary")
('license 'license:lgpl2.0)) ('license 'license:lgpl2.0))
(string=? (bytevector->nix-base32-string (file-sha256 tarball)) (string=? default-sha256/base32 hash))
hash))
(x (x
(pk 'fail x #f)))))) (pk 'fail x #f))))))
(test-equal "package-latest-release"
(list '("foo-1.0.0.tar.gz")
'("foo-1.0.0.tar.gz.asc")
(list (upstream-input
(name "bar")
(downstream-name "python-bar")
(type 'propagated))
(upstream-input
(name "foo")
(downstream-name "python-foo")
(type 'propagated))
(upstream-input
(name "pytest")
(downstream-name "python-pytest")
(type 'native))))
(let ((tarball (pypi-tarball
"foo-1.0.0"
`(("src/bizarre.egg-info/requires.txt"
,test-requires.txt)))))
(with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
("/foo/json" 200 ,(lambda (port)
(display (foo-json) port))))
(define source
(package-latest-release
(dummy-package "python-foo"
(version "0.1.2")
(source (dummy-origin
(method url-fetch)
(uri (pypi-uri "foo" version))))
(build-system python-build-system))
(list %pypi-updater)))
(list (map basename (upstream-source-urls source))
(map basename (upstream-source-signature-urls source))
(upstream-source-inputs source)))))
(test-end "pypi") (test-end "pypi")
(delete-file-recursively sample-directory) (delete-file-recursively sample-directory)

140
tests/upstream.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -78,69 +78,29 @@
(description "test") (description "test")
(license license:gpl3+))) (license license:gpl3+)))
(define test-package-sexp
'(package
(name "test")
(version "2.10")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/hello/hello-" version
".tar.gz"))
(sha256
(base32
"0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
(build-system gnu-build-system)
(inputs
`(("hello" ,hello)))
(native-inputs
`(("sed" ,sed)
("tar" ,tar)))
(propagated-inputs
`(("grep" ,grep)))
(home-page "http://localhost")
(synopsis "test")
(description "test")
(license license:gpl3+)))
(test-equal "changed-inputs returns no changes" (test-equal "changed-inputs returns no changes"
'() '()
(changed-inputs test-package test-package-sexp)) (changed-inputs test-package
(upstream-source
(test-assert "changed-inputs returns changes to labelled input list" (package "test")
(let ((changes (changed-inputs (version "1")
(package (urls '())
(inherit test-package) (inputs
(inputs `(("hello" ,hello) (let ((->input
("sed" ,sed)))) (lambda (type)
test-package-sexp))) (match-lambda
(match changes ((label _)
;; Exactly one change (upstream-input
(((? upstream-input-change? item)) (name label)
(and (equal? (upstream-input-change-type item) (downstream-name label)
'regular) (type type)))))))
(equal? (upstream-input-change-action item) (append (map (->input 'regular)
'remove) (package-inputs test-package))
(string=? (upstream-input-change-name item) (map (->input 'native)
"sed"))) (package-native-inputs test-package))
(else (pk else #false))))) (map (->input 'propagated)
(package-propagated-inputs
(test-assert "changed-inputs returns changes to all labelled input lists" test-package))))))))
(let ((changes (changed-inputs
(package
(inherit test-package)
(inputs '())
(native-inputs '())
(propagated-inputs '()))
test-package-sexp)))
(match changes
(((? upstream-input-change? items) ...)
(and (equal? (map upstream-input-change-type items)
'(regular native native propagated))
(equal? (map upstream-input-change-action items)
'(add add add add))
(equal? (map upstream-input-change-name items)
'("hello" "sed" "tar" "grep"))))
(else (pk else #false)))))
(define test-new-package (define test-new-package
(package (package
@ -152,35 +112,20 @@
(propagated-inputs (propagated-inputs
(list grep)))) (list grep))))
(define test-new-package-sexp
'(package
(name "test")
(version "2.10")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/hello/hello-" version
".tar.gz"))
(sha256
(base32
"0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
(build-system gnu-build-system)
(inputs
(list hello))
(native-inputs
(list sed tar))
(propagated-inputs
(list grep))
(home-page "http://localhost")
(synopsis "test")
(description "test")
(license license:gpl3+)))
(test-assert "changed-inputs returns changes to plain input list" (test-assert "changed-inputs returns changes to plain input list"
(let ((changes (changed-inputs (let ((changes (changed-inputs
(package (package
(inherit test-new-package) (inherit test-new-package)
(inputs (list hello sed))) (inputs (list hello sed))
test-new-package-sexp))) (native-inputs '())
(propagated-inputs '()))
(upstream-source
(package "test")
(version "1")
(urls '())
(inputs (list (upstream-input
(name "hello")
(downstream-name name))))))))
(match changes (match changes
;; Exactly one change ;; Exactly one change
(((? upstream-input-change? item)) (((? upstream-input-change? item))
@ -199,7 +144,26 @@
(inputs '()) (inputs '())
(native-inputs '()) (native-inputs '())
(propagated-inputs '())) (propagated-inputs '()))
test-new-package-sexp))) (upstream-source
(package "test")
(version "1")
(urls '())
(inputs (list (upstream-input
(name "hello")
(downstream-name name)
(type 'regular))
(upstream-input
(name "sed")
(downstream-name name)
(type 'native))
(upstream-input
(name "tar")
(downstream-name name)
(type 'native))
(upstream-input
(name "grep")
(downstream-name name)
(type 'propagated))))))))
(match changes (match changes
(((? upstream-input-change? items) ...) (((? upstream-input-change? items) ...)
(and (equal? (map upstream-input-change-type items) (and (equal? (map upstream-input-change-type items)