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.scm215
1 files changed, 166 insertions, 49 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 3fb2e213b0..463a25514e 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -23,6 +23,11 @@
#:use-module ((ice-9 rdelim) #:select (read-string))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-41)
+ #:use-module (ice-9 receive)
+ #:use-module (web uri)
+ #:use-module (guix combinators)
#:use-module (guix http-client)
#:use-module (guix hash)
#:use-module (guix store)
@@ -32,8 +37,10 @@
#:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
#:use-module (guix upstream)
#:use-module (guix packages)
+ #:use-module (gnu packages)
#:export (cran->guix-package
bioconductor->guix-package
+ recursive-import
%cran-updater
%bioconductor-updater))
@@ -51,19 +58,21 @@
("Artistic-2.0" 'artistic2.0)
("Apache License 2.0" 'asl2.0)
("BSD_2_clause" 'bsd-2)
+ ("BSD_2_clause + file LICENSE" 'bsd-2)
("BSD_3_clause" 'bsd-3)
+ ("BSD_3_clause + file LICENSE" 'bsd-3)
("GPL" (list 'gpl2+ 'gpl3+))
("GPL (>= 2)" 'gpl2+)
("GPL (>= 3)" 'gpl3+)
- ("GPL-2" 'gpl2+)
- ("GPL-3" 'gpl3+)
- ("LGPL-2" 'lgpl2.0+)
- ("LGPL-2.1" 'lgpl2.1+)
- ("LGPL-3" 'lgpl3+)
+ ("GPL-2" 'gpl2)
+ ("GPL-3" 'gpl3)
+ ("LGPL-2" 'lgpl2.0)
+ ("LGPL-2.1" 'lgpl2.1)
+ ("LGPL-3" 'lgpl3)
("LGPL (>= 2)" 'lgpl2.0+)
("LGPL (>= 3)" 'lgpl3+)
- ("MIT" 'x11)
- ("MIT + file LICENSE" 'x11)
+ ("MIT" 'expat)
+ ("MIT + file LICENSE" 'expat)
((x) (string->license x))
((lst ...) `(list ,@(map string->license lst)))
(_ #f)))
@@ -121,10 +130,18 @@ package definition."
(define (fetch-description base-url name)
"Return an alist of the contents of the DESCRIPTION file for the R package
-NAME, or #f on failure. NAME is case-sensitive."
+NAME, or #f in case of failure. NAME is case-sensitive."
;; This API always returns the latest release of the module.
(let ((url (string-append base-url name "/DESCRIPTION")))
- (description->alist (read-string (http-fetch url)))))
+ (guard (c ((http-get-error? c)
+ (format (current-error-port)
+ "error: failed to retrieve package information \
+from ~s: ~a (~s)~%"
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
+ #f))
+ (description->alist (read-string (http-fetch url))))))
(define (listify meta field)
"Look up FIELD in the alist META. If FIELD contains a comma-separated
@@ -146,14 +163,49 @@ empty list when the FIELD cannot be found."
(string-any char-set:whitespace item)))
(map string-trim-both items))))))
+(define default-r-packages
+ (list "KernSmooth"
+ "MASS"
+ "Matrix"
+ "base"
+ "boot"
+ "class"
+ "cluster"
+ "codetools"
+ "compiler"
+ "datasets"
+ "foreign"
+ "grDevices"
+ "graphics"
+ "grid"
+ "lattice"
+ "methods"
+ "mgcv"
+ "nlme"
+ "nnet"
+ "parallel"
+ "rpart"
+ "spatial"
+ "splines"
+ "stats"
+ "stats4"
+ "survival"
+ "tcltk"
+ "tools"
+ "translations"
+ "utils"))
+
+(define (guix-name name)
+ "Return a Guix package name for a given R package name."
+ (string-append "r-" (string-map (match-lambda
+ (#\_ #\-)
+ (#\. #\-)
+ (chr (char-downcase chr)))
+ name)))
+
(define (description->package repository meta)
"Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
- (define (guix-name name)
- (if (string-prefix? "r-" name)
- (string-downcase name)
- (string-append "r-" (string-downcase name))))
-
(let* ((base-url (case repository
((cran) %cran-url)
((bioconductor) %bioconductor-url)))
@@ -174,42 +226,107 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(_ #f)))
(tarball (with-store store (download-to-store store source-url)))
(sysdepends (map string-downcase (listify meta "SystemRequirements")))
- (propagate (map guix-name (lset-union equal?
- (listify meta "Imports")
- (listify meta "LinkingTo")
- (delete "R"
- (listify meta "Depends"))))))
- `(package
- (name ,(guix-name name))
- (version ,version)
- (source (origin
- (method url-fetch)
- (uri (,(procedure-name uri-helper) ,name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string (file-sha256 tarball))))))
- ,@(if (not (equal? (string-append "r-" name)
- (guix-name name)))
- `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
- '())
- (build-system r-build-system)
- ,@(maybe-inputs sysdepends)
- ,@(maybe-inputs propagate 'propagated-inputs)
- (home-page ,(if (string-null? home-page)
- (string-append base-url name)
- home-page))
- (synopsis ,synopsis)
- (description ,(beautify-description (assoc-ref meta "Description")))
- (license ,license))))
-
-(define* (cran->guix-package package-name #:optional (repo 'cran))
- "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
+ (propagate (filter (lambda (name)
+ (not (member name default-r-packages)))
+ (lset-union equal?
+ (listify meta "Imports")
+ (listify meta "LinkingTo")
+ (delete "R"
+ (listify meta "Depends"))))))
+ (values
+ `(package
+ (name ,(guix-name name))
+ (version ,version)
+ (source (origin
+ (method url-fetch)
+ (uri (,(procedure-name uri-helper) ,name version))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string (file-sha256 tarball))))))
+ ,@(if (not (equal? (string-append "r-" name)
+ (guix-name name)))
+ `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
+ '())
+ (build-system r-build-system)
+ ,@(maybe-inputs sysdepends)
+ ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs)
+ (home-page ,(if (string-null? home-page)
+ (string-append base-url name)
+ home-page))
+ (synopsis ,synopsis)
+ (description ,(beautify-description (or (assoc-ref meta "Description")
+ "")))
+ (license ,license))
+ propagate)))
+
+(define cran->guix-package
+ (memoize
+ (lambda* (package-name #:optional (repo 'cran))
+ "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
- (let* ((url (case repo
- ((cran) %cran-url)
- ((bioconductor) %bioconductor-svn-url)))
- (module-meta (fetch-description url package-name)))
- (and=> module-meta (cut description->package repo <>))))
+ (let* ((url (case repo
+ ((cran) %cran-url)
+ ((bioconductor) %bioconductor-svn-url)))
+ (module-meta (fetch-description url package-name)))
+ (and=> module-meta (cut description->package repo <>))))))
+
+(define* (recursive-import package-name #:optional (repo 'cran))
+ "Generate a stream of package expressions for PACKAGE-NAME and all its
+dependencies."
+ (receive (package . dependencies)
+ (cran->guix-package package-name repo)
+ (if (not package)
+ stream-null
+
+ ;; Generate a lazy stream of package expressions for all unknown
+ ;; dependencies in the graph.
+ (let* ((make-state (lambda (queue done)
+ (cons queue done)))
+ (next (match-lambda
+ (((next . rest) . done) next)))
+ (imported (match-lambda
+ ((queue . done) done)))
+ (done? (match-lambda
+ ((queue . done)
+ (zero? (length queue)))))
+ (unknown? (lambda* (dependency #:optional (done '()))
+ (and (not (member dependency
+ done))
+ (null? (find-packages-by-name
+ (guix-name dependency))))))
+ (update (lambda (state new-queue)
+ (match state
+ (((head . tail) . done)
+ (make-state (lset-difference
+ equal?
+ (lset-union equal? new-queue tail)
+ done)
+ (cons head done)))))))
+ (stream-cons
+ package
+ (stream-unfold
+ ;; map: produce a stream element
+ (lambda (state)
+ (cran->guix-package (next state) repo))
+
+ ;; predicate
+ (compose not done?)
+
+ ;; generator: update the queue
+ (lambda (state)
+ (receive (package . dependencies)
+ (cran->guix-package (next state) repo)
+ (if package
+ (update state (filter (cut unknown? <>
+ (cons (next state)
+ (imported state)))
+ (car dependencies)))
+ ;; TODO: Try the other archives before giving up
+ (update state (imported state)))))
+
+ ;; initial state
+ (make-state (filter unknown? (car dependencies))
+ (list package-name))))))))
;;;
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-09 23:06:19 +0000