summaryrefslogtreecommitdiff
path: root/guix/import/cran.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import/cran.scm')
-rw-r--r--guix/import/cran.scm194
1 files changed, 125 insertions, 69 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb271634ed..d25f334396 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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 © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -164,24 +164,16 @@
rest)))))))
(fold parse '() lines)))
-(define (format-inputs names)
- "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))
+(define* (maybe-inputs package-inputs #:optional (input-type 'inputs))
"Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
package definition."
(match 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-canonical-url "https://cran.r-project.org/package=")
@@ -520,14 +512,29 @@ the pkg-config tool."
"(Makevars.*|configure.*)"))
(define (source-dir->dependencies dir)
- "Guess dependencies of R package source in DIR and return two values: a list
-of package names for INPUTS and another list of names of NATIVE-INPUTS."
- (values
- (needed-libraries-in-directory dir)
- (append
- (if (directory-needs-esbuild? dir) '("esbuild") '())
- (if (directory-needs-pkg-config? dir) '("pkg-config") '())
- (if (directory-needs-fortran? dir) '("gfortran") '()))))
+ "Guess dependencies of R package source in DIR and return a list of
+<upstream-input> corresponding to the dependencies guessed from source files
+in DIR."
+ (define (native name)
+ (upstream-input
+ (name name)
+ (downstream-name name)
+ (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?)
"SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated
@@ -541,7 +548,79 @@ by TARBALL?"
(source-dir->dependencies source)))
(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)
(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)
((bioconductor) %bioconductor-url)
((git) #f)))
- (uri-helper (case repository
- ((cran) cran-uri)
- ((bioconductor) bioconductor-uri)
- ((git) #f)
- ((hg) #f)))
(name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title"))
(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")
((url rest ...) url)
(_ (string-append canonical-url-base name))))))
- (source-url (case 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)))))
+ (source-url (cran-package-source-url meta repository))
(git? (if (assoc-ref meta 'git) #true #false))
(hg? (if (assoc-ref meta 'hg) #true #false))
(source (download-source source-url #:method (cond
(git? 'git)
(hg? 'hg)
(else #f))))
- (tarball? (not (or git? hg?)))
- (source-inputs source-native-inputs
- (source->dependencies source tarball?))
- (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")))))
+ (uri-helper (uri-helper repository))
+ (inputs (cran-package-inputs meta repository
+ #:download-source download-source))
(package
`(package
(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)))))
'())
(build-system r-build-system)
- ,@(maybe-inputs (map transform-sysname sysdepends))
- ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
- ,@(maybe-inputs
- `(,@source-native-inputs
- ,@(vignette-builders meta))
- 'native-inputs)
+
+ ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular)
+ inputs)
+ 'inputs)
+ ,@(maybe-inputs (filter (upstream-input-type-predicate
+ 'propagated)
+ inputs)
+ 'propagated-inputs)
+ ,@(maybe-inputs (filter (upstream-input-type-predicate 'native)
+ inputs)
+ 'native-inputs)
+
(home-page ,(if (string-null? home-page)
(string-append base-url name)
home-page))
@@ -675,7 +731,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(revision "1"))
,package))
(else package))
- propagate)))
+ (filter-map (lambda (input)
+ (and (eq? 'propagated (upstream-input-type input))
+ (upstream-input-name input)))
+ inputs))))
(define cran->guix-package
(memoize
@@ -760,9 +819,7 @@ s-expression corresponding to that package, or #f on failure."
(package (package-name pkg))
(version version)
(urls (cran-uri upstream-name version))
- (input-changes
- (changed-inputs pkg
- (description->package 'cran meta)))))))
+ (inputs (cran-package-inputs meta 'cran))))))
(define* (latest-bioconductor-release pkg #:key (version #f))
"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))
(version latest-version)
(urls (bioconductor-uri upstream-name latest-version))
- (input-changes
- (changed-inputs
- pkg
- (cran->guix-package upstream-name #:repo 'bioconductor))))))
+ (inputs
+ (let ((meta (fetch-description 'bioconductor upstream-name)))
+ (cran-package-inputs meta 'bioconductor))))))
(define (cran-package? package)
"Return true if PACKAGE is an R package from CRAN."