diff options
Diffstat (limited to 'guix/import/cran.scm')
| -rw-r--r-- | guix/import/cran.scm | 194 |
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." |