refresh: Suggest input changes when updating.

* guix/upstream.scm (<upstream-source>)[input-changes]: New field.
(<upstream-input-change>): New record.
(upstream-input-change?, upstream-input-change-name,
upstream-input-change-type, upstream-input-change-action, changed-inputs): New
procedures.
(package-update): Pass along input changes.
* guix/script/refresh.scm (update-package): Process input changes.
This commit is contained in:
Ricardo Wurmus 2019-01-11 09:26:44 +01:00
parent ea600ff709
commit 7e634c2f53
No known key found for this signature in database
GPG key ID: 197A5888235FACAC
2 changed files with 104 additions and 9 deletions

View file

@ -6,6 +6,7 @@
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -296,7 +297,7 @@ (define* (update-package store package updaters
values: 'interactive' (default), 'always', and 'never'. When WARN? is true, values: 'interactive' (default), 'always', and 'never'. When WARN? is true,
warn about packages that have no matching updater." warn about packages that have no matching updater."
(if (lookup-updater package updaters) (if (lookup-updater package updaters)
(let-values (((version tarball) (let-values (((version tarball changes)
(package-update store package updaters (package-update store package updaters
#:key-download key-download)) #:key-download key-download))
((loc) ((loc)
@ -310,6 +311,26 @@ (define* (update-package store package updaters
(location->string loc) (location->string loc)
(package-name package) (package-name package)
(package-version package) version) (package-version package) version)
(for-each
(lambda (change)
(format (current-error-port)
(match (list (upstream-input-change-action change)
(upstream-input-change-type change))
(('add 'regular)
(G_ "~a: consider adding this input: ~a~%"))
(('add 'native)
(G_ "~a: consider adding this native input: ~a~%"))
(('add 'propagated)
(G_ "~a: consider adding this propagated input: ~a~%"))
(('remove 'regular)
(G_ "~a: consider removing this input: ~a~%"))
(('remove 'native)
(G_ "~a: consider removing this native input: ~a~%"))
(('remove 'propagated)
(G_ "~a: consider removing this propagated input: ~a~%")))
(package-name package)
(upstream-input-change-name change)))
(changes))
(let ((hash (call-with-input-file tarball (let ((hash (call-with-input-file tarball
port-sha256))) port-sha256)))
(update-package-source package version hash))) (update-package-source package version hash)))

View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -45,6 +46,7 @@ (define-module (guix upstream)
upstream-source-urls upstream-source-urls
upstream-source-signature-urls upstream-source-signature-urls
upstream-source-archive-types upstream-source-archive-types
upstream-source-input-changes
url-prefix-predicate url-prefix-predicate
coalesce-sources coalesce-sources
@ -56,6 +58,12 @@ (define-module (guix upstream)
upstream-updater-predicate upstream-updater-predicate
upstream-updater-latest upstream-updater-latest
upstream-input-change?
upstream-input-change-name
upstream-input-change-type
upstream-input-change-action
changed-inputs
%updaters %updaters
lookup-updater lookup-updater
@ -82,7 +90,73 @@ (define-record-type* <upstream-source>
(version upstream-source-version) ;string (version upstream-source-version) ;string
(urls upstream-source-urls) ;list of strings (urls upstream-source-urls) ;list of strings
(signature-urls upstream-source-signature-urls ;#f | list of strings (signature-urls upstream-source-signature-urls ;#f | list of strings
(default #f))) (default #f))
(input-changes upstream-source-input-changes
(default '()) (thunked)))
;; Representation of an upstream input change.
(define-record-type* <upstream-input-change>
upstream-input-change make-upstream-input-change
upstream-input-change?
(name upstream-input-change-name) ;string
(type upstream-input-change-type) ;symbol: regular | native | propagated
(action upstream-input-change-action)) ;symbol: add | remove
(define (changed-inputs package package-sexp)
"Return a list of input changes for PACKAGE based on the newly imported
S-expression PACKAGE-SEXP."
(match package-sexp
((and expr ('package fields ...))
(let* ((input->name (match-lambda ((name pkg . out) name)))
(new-regular
(match expr
((path *** ('inputs
('quasiquote ((label ('unquote sym)) ...)))) label)
(_ '())))
(new-native
(match expr
((path *** ('native-inputs
('quasiquote ((label ('unquote sym)) ...)))) label)
(_ '())))
(new-propagated
(match expr
((path *** ('propagated-inputs
('quasiquote ((label ('unquote sym)) ...)))) label)
(_ '())))
(current-regular
(map input->name (package-inputs package)))
(current-native
(map input->name (package-native-inputs package)))
(current-propagated
(map input->name (package-propagated-inputs package))))
(append-map
(match-lambda
((action type names)
(map (lambda (name)
(upstream-input-change
(name name)
(type type)
(action action)))
names)))
`((add regular
,(lset-difference equal?
new-regular current-regular))
(remove regular
,(lset-difference equal?
current-regular new-regular))
(add native
,(lset-difference equal?
new-native current-native))
(remove native
,(lset-difference equal?
current-native new-native))
(add propagated
,(lset-difference equal?
new-propagated current-propagated))
(remove propagated
,(lset-difference equal?
current-propagated new-propagated))))))
(_ '())))
(define (url-prefix-predicate prefix) (define (url-prefix-predicate prefix)
"Return a predicate that returns true when passed a package where one of its "Return a predicate that returns true when passed a package where one of its
@ -268,12 +342,12 @@ (define (find2 pred lst1 lst2)
(define* (package-update store package updaters (define* (package-update store package updaters
#:key (key-download 'interactive)) #:key (key-download 'interactive))
"Return the new version and the file name of the new version tarball for "Return the new version, the file name of the new version tarball, and input
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
download policy for missing OpenPGP keys; allowed values: 'always', 'never', KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
and 'interactive' (default)." values: 'always', 'never', and 'interactive' (default)."
(match (package-latest-release* package updaters) (match (package-latest-release* package updaters)
(($ <upstream-source> _ version urls signature-urls) (($ <upstream-source> _ version urls signature-urls changes)
(let*-values (((name) (let*-values (((name)
(package-name package)) (package-name package))
((archive-type) ((archive-type)
@ -299,9 +373,9 @@ (define* (package-update store package updaters
(or signature-urls (circular-list #f))))) (or signature-urls (circular-list #f)))))
(let ((tarball (download-tarball store url signature-url (let ((tarball (download-tarball store url signature-url
#:key-download key-download))) #:key-download key-download)))
(values version tarball)))) (values version tarball changes))))
(#f (#f
(values #f #f)))) (values #f #f #f))))
(define (update-package-source package version hash) (define (update-package-source package version hash)
"Modify the source file that defines PACKAGE to refer to VERSION, "Modify the source file that defines PACKAGE to refer to VERSION,