import/cran: Allow custom license prefix.
* guix/import/cran.scm (string-licenses): Add license-prefix argument. (string->license): Ditto. (description->package): Ditto. (cran->guix-package): Ditto. (cran-recursive-import): Ditto. * guix/scripts/import/cran.scm (%options): Add new option -p/--license-prefix. (show-help): Document it. (parse-options): Pass it to importer. * doc/guix.texi (Invoking guix import): Document it.
This commit is contained in:
Lars-Dominik Braun
Ricardo Wurmus
parent
3c24da4260
commit
d57dd25d38
@ -13499,6 +13499,10 @@ definitions are to be appended to existing user modules, as the list of
|
||||
used package modules need not be changed. The default is
|
||||
@option{--style=variable}.
|
||||
|
||||
When @option{--prefix=license:} is added, the importer will prefix
|
||||
license atoms with @code{license:}, allowing a prefixed import of
|
||||
@code{(guix licenses)}.
|
||||
|
||||
When @option{--archive=bioconductor} is added, metadata is imported from
|
||||
@uref{https://www.bioconductor.org/, Bioconductor}, a repository of R
|
||||
packages for the analysis and comprehension of high-throughput
|
||||
|
||||
@ -83,16 +83,16 @@
|
||||
(define %input-style
|
||||
(make-parameter 'variable)) ; or 'specification
|
||||
|
||||
(define (string->licenses license-string)
|
||||
(define (string->licenses license-string license-prefix)
|
||||
(let ((licenses
|
||||
(map string-trim-both
|
||||
(string-tokenize license-string
|
||||
(char-set-complement (char-set #\|))))))
|
||||
(string->license licenses)))
|
||||
(string->license licenses license-prefix)))
|
||||
|
||||
(define string->license
|
||||
(let ((prefix identity))
|
||||
(match-lambda
|
||||
(define (string->license license-string license-prefix)
|
||||
(let ((prefix license-prefix))
|
||||
(match license-string
|
||||
("AGPL-3" (prefix 'agpl3))
|
||||
("AGPL (>= 3)" (prefix 'agpl3+))
|
||||
("Artistic-2.0" (prefix 'artistic2.0))
|
||||
@ -138,8 +138,8 @@
|
||||
("MIT + file LICENSE" (prefix 'expat))
|
||||
("file LICENSE"
|
||||
`(,(prefix 'fsdg-compatible) "file://LICENSE"))
|
||||
((x) (string->license x))
|
||||
((lst ...) `(list ,@(map string->license lst)))
|
||||
((x) (string->license x license-prefix))
|
||||
((lst ...) `(list ,@(map (cut string->license <> license-prefix) lst)))
|
||||
(unknown `(,(prefix 'fsdg-compatible) ,unknown)))))
|
||||
|
||||
(define (description->alist description)
|
||||
@ -508,7 +508,7 @@ reference the pkg-config tool."
|
||||
(define (needs-knitr? meta)
|
||||
(member "knitr" (listify meta "VignetteBuilder")))
|
||||
|
||||
(define (description->package repository meta)
|
||||
(define* (description->package repository meta #:key (license-prefix identity))
|
||||
"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."
|
||||
(let* ((base-url (case repository
|
||||
@ -528,7 +528,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
|
||||
(name (assoc-ref meta "Package"))
|
||||
(synopsis (assoc-ref meta "Title"))
|
||||
(version (assoc-ref meta "Version"))
|
||||
(license (string->licenses (assoc-ref meta "License")))
|
||||
(license (string->licenses (assoc-ref meta "License") license-prefix))
|
||||
;; Some packages have multiple home pages. Some have none.
|
||||
(home-page (case repository
|
||||
((git) (assoc-ref meta 'git))
|
||||
@ -644,31 +644,38 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
|
||||
|
||||
(define cran->guix-package
|
||||
(memoize
|
||||
(lambda* (package-name #:key (repo 'cran) version #:allow-other-keys)
|
||||
(lambda* (package-name #:key (repo 'cran) version (license-prefix identity)
|
||||
#:allow-other-keys)
|
||||
"Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
|
||||
s-expression corresponding to that package, or #f on failure."
|
||||
(let ((description (fetch-description repo package-name version)))
|
||||
(if description
|
||||
(description->package repo description)
|
||||
(description->package repo description
|
||||
#:license-prefix license-prefix)
|
||||
(case repo
|
||||
((git)
|
||||
;; Retry import from Bioconductor
|
||||
(cran->guix-package package-name #:repo 'bioconductor))
|
||||
(cran->guix-package package-name #:repo 'bioconductor
|
||||
#:license-prefix license-prefix))
|
||||
((hg)
|
||||
;; Retry import from Bioconductor
|
||||
(cran->guix-package package-name #:repo 'bioconductor))
|
||||
(cran->guix-package package-name #:repo 'bioconductor
|
||||
#:license-prefix license-prefix))
|
||||
((bioconductor)
|
||||
;; Retry import from CRAN
|
||||
(cran->guix-package package-name #:repo 'cran))
|
||||
(cran->guix-package package-name #:repo 'cran
|
||||
#:license-prefix license-prefix))
|
||||
(else
|
||||
(values #f '()))))))))
|
||||
|
||||
(define* (cran-recursive-import package-name #:key (repo 'cran) version)
|
||||
(define* (cran-recursive-import package-name #:key (repo 'cran) version
|
||||
(license-prefix identity))
|
||||
(recursive-import package-name
|
||||
#:version version
|
||||
#:repo repo
|
||||
#:repo->guix-package cran->guix-package
|
||||
#:guix-name cran-guix-name))
|
||||
#:guix-name cran-guix-name
|
||||
#:license-prefix license-prefix))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
@ -53,6 +53,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
|
||||
(display (G_ "
|
||||
-s, --style=STYLE choose output style, either specification or variable"))
|
||||
(display (G_ "
|
||||
-p, --license-prefix=PREFIX
|
||||
add custom prefix to licenses"))
|
||||
(display (G_ "
|
||||
-V, --version display version information and exit"))
|
||||
(newline)
|
||||
(show-bug-report-information))
|
||||
@ -74,6 +77,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'style (string->symbol arg)
|
||||
(alist-delete 'style result))))
|
||||
(option '(#\p "license-prefix") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'license-prefix arg
|
||||
(alist-delete 'license-prefix result))))
|
||||
(option '(#\r "recursive") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'recursive #t result)))
|
||||
@ -95,7 +102,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
|
||||
(('argument . value)
|
||||
value)
|
||||
(_ #f))
|
||||
(reverse opts))))
|
||||
(reverse opts)))
|
||||
(prefix (assoc-ref opts 'license-prefix))
|
||||
(prefix-proc (if (string? prefix)
|
||||
(lambda (symbol)
|
||||
(string->symbol
|
||||
(string-append prefix (symbol->string symbol))))
|
||||
identity)))
|
||||
(parameterize ((%input-style (assoc-ref opts 'style)))
|
||||
(match args
|
||||
((spec)
|
||||
@ -107,11 +120,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
|
||||
(filter identity
|
||||
(cran-recursive-import name
|
||||
#:version version
|
||||
#:repo (or (assoc-ref opts 'repo) 'cran)))))
|
||||
#:repo (or (assoc-ref opts 'repo) 'cran)
|
||||
#:license-prefix prefix-proc))))
|
||||
;; Single import
|
||||
(let ((sexp (cran->guix-package name
|
||||
#:version version
|
||||
#:repo (or (assoc-ref opts 'repo) 'cran))))
|
||||
#:repo (or (assoc-ref opts 'repo) 'cran)
|
||||
#:license-prefix prefix-proc)))
|
||||
(unless sexp
|
||||
(leave (G_ "failed to download description for package '~a'~%")
|
||||
name))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user