[PATCH] refresh: Suggest changes to inputs when updating.

[Ricardo Wurmus]

* guix/scripts/refresh.scm (updater->importer-info): New procedure.
(mock): New syntax rule.
(update-package): Run matching importer to suggest changes to inputs.
---
 guix/scripts/refresh.scm | 98 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 97 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index b81c69f..861972c 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;; Copyright © 2015 Alex Kost <address@hidden>
 ;;; Copyright © 2016 Ben Woodcroft <address@hidden>
+;;; Copyright © 2016 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -208,6 +209,35 @@ unavailable optional dependencies such as Guile-JSON."
                  ((guix import gem) => %gem-updater)
                  ((guix import github) => %github-updater)))
 
+(define (updater->importer-info updater-name)
+  "Return a list containing an update procedure, a package name converter,
+and, optionally, an archive symbol for the given UPDATER-NAME.  Return #F for
+an unknown updater."
+  (case updater-name
+    ((gnu)
+     (list gnu->guix-package
+           package-name))
+    ((elpa)
+     (list elpa->guix-package
+           package-name))
+    ((cran)
+     (list cran->guix-package
+           (@@ (guix import cran) package->upstream-name)))
+    ((bioconductor)
+     (list cran->guix-package
+           (@@ (guix import cran) package->upstream-name)
+           'bioconductor))
+    ((hackage)
+     (list hackage->guix-package
+           (@@ (guix import gem) guix-package->hackage-name)))
+    ((pypi)
+     (list pypi->guix-package
+           guix-package->pypi-name))
+    ((gem)
+     (list gem->guix-package
+           (@@ (guix import gem) guix-package->gem-name)))
+    (else #f)))
+
 (define (lookup-updater name)
   "Return the updater called NAME."
   (or (find (lambda (updater)
@@ -225,6 +255,17 @@ unavailable optional dependencies such as Guile-JSON."
             %updaters)
   (exit 0))
 
+;; FIXME: copied from (guix tests)
+(define-syntax-rule (mock (module proc replacement) body ...)
+  "Within BODY, replace the definition of PROC from MODULE with the definition
+given by REPLACEMENT."
+  (let* ((m (resolve-module 'module))
+         (original (module-ref m 'proc)))
+    (dynamic-wind
+      (lambda () (module-set! m 'proc replacement))
+      (lambda () body ...)
+      (lambda () (module-set! m 'proc original)))))
+
 (define* (update-package store package updaters
                          #:key (key-download 'interactive))
   "Update the source file that defines PACKAGE with the new version.
@@ -246,7 +287,62 @@ values: 'interactive' (default), 'always', and 'never'."
                     (package-version package) version)
             (let ((hash (call-with-input-file tarball
                           port-sha256)))
-              (update-package-source package version hash)))
+              (update-package-source package version hash))
+
+            ;; Run importer to compare inputs and suggest changes.
+            (let* ((updater (find (lambda (updater)
+                                    ((upstream-updater-predicate updater) 
package))
+                                  updaters))
+                   (updater-name (upstream-updater-name updater)))
+              (match (updater->importer-info updater-name)
+                (#f #t) ; do nothing if there's no matching importer
+                ((importer convert-name . archive)
+                 ;; Replace "download-to-store" to avoid downloading the
+                 ;; tarball again.
+                 (match (mock ((guix download) download-to-store
+                               (lambda _ tarball))
+                         (apply importer (convert-name package) archive))
+                   ((and expr ('package fields ...))
+                    ;; FIXME: Is there a nicer way to match names in the
+                    ;; package expression?  Could we compare actual packages
+                    ;; instead of only their labels?
+                    (let* ((imported-inputs
+                            (append
+                             (match expr
+                               ((path *** ('inputs
+                                           ('quasiquote ((label ('unquote 
sym)) ...)))) label)
+                               (_ '()))
+                             (match expr
+                               ((path *** ('native-inputs
+                                           ('quasiquote ((label ('unquote 
sym)) ...)))) label)
+                               (_ '()))
+                             (match expr
+                               ((path *** ('propagated-inputs
+                                           ('quasiquote ((label ('unquote 
sym)) ...)))) label)
+                               (_ '()))))
+                           (current-inputs
+                            (map (match-lambda ((name pkg) name))
+                                 (package-direct-inputs package)))
+                           (removed
+                            (lset-difference equal?
+                                             current-inputs
+                                             imported-inputs))
+                           (added
+                            (lset-difference equal?
+                                             imported-inputs
+                                             current-inputs)))
+                      (when (not (null? removed))
+                        (format (current-error-port)
+                                (_ "~a: consider removing these inputs:~{ 
~a~}~%")
+                                (package-name package)
+                                removed))
+                      (when (not (null? added))
+                        (format (current-error-port)
+                                (_ "~a: consider adding these inputs:~{ 
~a~}~%")
+                                (package-name package)
+                                added))))
+                   (x
+                    (leave (_ "'~a' import failed~%") importer)))))))
           (warning (_ "~a: version ~a could not be \
 downloaded and authenticated; not updating~%")
                    (package-name package) version)))))
-- 
2.10.1