From 7d095e3ea747c9863289059fa839d2367fe3345a Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Tue, 18 Oct 2022 12:45:15 +0200 Subject: [PATCH v2 2/6] import/cran: Allow custom license prefix. * guix/import/cran.scm (string-licenses): Add license-prefix parameter. (string->license): Ditto. (description->package): Ditto. (cran->guix-package): Ditto. (cran-recursive-import): Ditto. * guix/scripts/import/cran.scm (%options): Add new parameter -p/--license-prefix. (show-help): Document it. (parse-options): Pass it to importer. * doc/guix.texi (Invoking guix import): Document it. --- doc/guix.texi | 4 ++++ guix/import/cran.scm | 39 +++++++++++++++++++++--------------- guix/scripts/import/cran.scm | 21 ++++++++++++++++--- 3 files changed, 45 insertions(+), 19 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 47b805dc7f..76cf3abea9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13486,6 +13486,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 diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 41e5d45acf..c24862129f 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -82,16 +82,16 @@ (define-module (guix import cran) (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)) @@ -137,8 +137,8 @@ (define string->license ("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) @@ -503,7 +503,7 @@ (define (needs-pkg-config? thing tarball?) (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 @@ -523,7 +523,7 @@ (define (description->package repository meta) (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)) @@ -639,31 +639,38 @@ (define (description->package repository meta) (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)) ;;; diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 2934d4300a..5298f059f2 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -53,6 +53,9 @@ (define (show-help) (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 @@ (define %options (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 @@ (define (parse-options) (('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 @@ (define (parse-options) (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)) -- 2.37.4