[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] refresh: Suggest changes to inputs when updating.
From: |
Ricardo Wurmus |
Subject: |
[PATCH] refresh: Suggest changes to inputs when updating. |
Date: |
Tue, 25 Oct 2016 21:51:42 +0200 |
* 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
- [PATCH] refresh: Suggest changes to inputs when updating.,
Ricardo Wurmus <=