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.

doc/guix.texi

@@ -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

guix/import/cran.scm

@@ -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
+(define (string->license license-string license-prefix)
-  (let ((prefix identity))
+  (let ((prefix license-prefix))
-    (match-lambda
+    (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))
+      ((x) (string->license x license-prefix))
-      ((lst ...) `(list ,@(map string->license lst)))
+      ((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))
 
 
 ;;;

guix/scripts/import/cran.scm

@@ -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))