Merge branch 'master' into staging

2 files changed, 95 insertions, 59 deletions

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 @@ 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))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index e0b94ce48d..6498d73c2b 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -183,9 +183,31 @@ specified with `--select'.\n"))
   (newline)
   (show-bug-report-information))
 
+
+;;;
+;;; Utilities.
+;;;
+
+(define-record-type <update-spec>
+  (%update-spec package version)
+  update?
+  (package update-spec-package)
+  (version update-spec-version))
+
+(define* (update-spec package #:optional version)
+  (%update-spec package version))
+
+(define (update-specification->update-spec spec)
+  "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update>
+record with two fields: the package to upgrade, and the target version."
+  (match (string-rindex spec #\=)
+    (#f  (update-spec (specification->package spec) #f))
+    (idx (update-spec (specification->package (substring spec 0 idx))
+                      (substring spec (1+ idx))))))
+
 (define (options->update-specs opts)
-  "Return the list of packages requested by OPTS, honoring options like
-'--recursive'."
+  "Return the list of <update-spec> records requested by OPTS, honoring
+options like '--recursive'."
   (define core-package?
     (let* ((input->package (match-lambda
                              ((name (? package? package) _ ...) package)
@@ -220,60 +242,43 @@ update would trigger a complete rebuild."
         (_
          (cons package lst)))))
 
-  (define args-packages
-    ;; Packages explicitly passed as command-line arguments.
-    (match (filter-map (match-lambda
+  (define update-specs
+    ;; Update specs explicitly passed as command-line arguments.
+    (match (append-map (match-lambda
                          (('argument . spec)
                           ;; Take either the specified version or the
                           ;; latest one.
-                          (update-specification->update-spec spec))
+                          (list (update-specification->update-spec spec)))
                          (('expression . exp)
-                          (read/eval-package-expression exp))
-                         (_ #f))
+                          (list (update-spec (read/eval-package-expression exp))))
+                         (('manifest . manifest)
+                          (map update-spec (packages-from-manifest manifest)))
+                         (_
+                          '()))
                        opts)
       (()                                         ;default to all packages
        (let ((select? (match (assoc-ref opts 'select)
                         ('core core-package?)
                         ('non-core (negate core-package?))
                         (_ (const #t)))))
-         (fold-packages (lambda (package result)
-                          (if (select? package)
-                              (keep-newest package result)
-                              result))
-                        '())))
+         (map update-spec
+              (fold-packages (lambda (package result)
+                               (if (select? package)
+                                   (keep-newest package result)
+                                   result))
+                             '()))))
       (some                                       ;user-specified packages
        some)))
 
-  (define packages
-    (match (assoc-ref opts 'manifest)
-      (#f args-packages)
-      ((? string? file) (packages-from-manifest file))))
-
   (if (assoc-ref opts 'recursive?)
-      (mlet %store-monad ((edges (node-edges %bag-node-type
-                                             (all-packages))))
-        (return (node-transitive-edges packages edges)))
+      (mlet* %store-monad ((edges (node-edges %bag-node-type (all-packages)))
+                           (packages -> (node-transitive-edges
+                                         (map update-spec-package update-specs)
+                                         edges)))
+        ;; FIXME: The 'version' field of each update spec is lost.
+        (return (map update-spec packages)))
       (with-monad %store-monad
-        (return packages))))
-
-
-;;;
-;;; Utilities.
-;;;
-
-(define-record-type <update-spec>
-  (update-spec package version)
-  update?
-  (package update-spec-package)
-  (version update-spec-version))
-
-(define (update-specification->update-spec spec)
-  "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update>
-record with two fields: the package to upgrade, and the target version."
-  (match (string-rindex spec #\=)
-    (#f  (update-spec (specification->package spec) #f))
-    (idx (update-spec (specification->package (substring spec 0 idx))
-                      (substring spec (1+ idx))))))
+        (return update-specs))))
 
 
 ;;;
@@ -382,10 +387,15 @@ downloaded and authenticated; not updating~%")
       (when warn?
         (warn-no-updater package))))
 
-(define* (check-for-package-update package updaters #:key warn?)
-  "Check whether an update is available for PACKAGE and print a message.  When
-WARN? is true and no updater exists for PACKAGE, print a warning."
-  (match (package-latest-release package updaters)
+(define* (check-for-package-update update-spec updaters #:key warn?)
+  "Check whether UPDATE-SPEC is feasible, and print a message.
+When WARN? is true and no updater exists for PACKAGE, print a warning."
+  (define package
+    (update-spec-package update-spec))
+
+  (match (package-latest-release package updaters
+                                 #:version
+                                 (update-spec-version update-spec))
     ((? upstream-source? source)
      (let ((loc (or (package-field-location package 'version)
                     (package-location package))))
@@ -403,23 +413,34 @@ WARN? is true and no updater exists for PACKAGE, print a warning."
                   (package-version package)
                   (package-name package))))
          (else
-          (when warn?
-            (warning loc
-                     (G_ "~a is greater than \
+          (if (update-spec-version update-spec)
+              (info loc
+                    (G_ "~a would be downgraded from ~a to ~a~%")
+                    (package-name package)
+                    (package-version package)
+                    (upstream-source-version source))
+              (when warn?
+                (warning loc
+                         (G_ "~a is greater than \
 the latest known version of ~a (~a)~%")
-                     (package-version package)
-                     (package-name package)
-                     (upstream-source-version source)))))))
+                         (package-version package)
+                         (package-name package)
+                         (upstream-source-version source))))))))
     (#f
      (when warn?
        ;; Distinguish between "no updater" and "failing updater."
        (match (lookup-updater package updaters)
          ((? upstream-updater? updater)
-          (warning (package-location package)
-                   (G_ "'~a' updater failed to determine available \
+          (if (update-spec-version update-spec)
+              (warning (G_ "'~a' updater failed to find version ~a of '~a'~%")
+                       (upstream-updater-name updater)
+                       (update-spec-version update-spec)
+                       (package-name package))
+              (warning (package-location package)
+                       (G_ "'~a' updater failed to determine available \
 releases for ~a~%")
-                   (upstream-updater-name updater)
-                   (package-name package)))
+                       (upstream-updater-name updater)
+                       (package-name package))))
          (#f
           (warn-no-updater package)))))))
 
@@ -591,5 +612,5 @@ all are dependent packages: ~{~a~^ ~}~%")
              (else
               (for-each (cut check-for-package-update <> updaters
                              #:warn? warn?)
-                        (map update-spec-package update-specs))
+                        update-specs)
               (return #t)))))))))