Add 'guix style'.

* guix/scripts/style.scm, tests/style.scm: New files.
* Makefile.am (MODULES, SCM_TESTS): Add them.
* po/guix/POTFILES.in: Add 'guix/scripts/style.scm'.
* doc/guix.texi (Invoking guix style): New node.
(package Reference): Reference it.
(Invoking guix lint): Likewise.

5 files changed, 994 insertions, 2 deletions

diff --git a/Makefile.am b/Makefile.am
index 05f013e3c2..7d5f6a7fa2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -286,6 +286,7 @@ MODULES =					\
   guix/scripts/refresh.scm			\
   guix/scripts/repl.scm				\
   guix/scripts/describe.scm			\
+  guix/scripts/style.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
   guix/scripts/system/reconfigure.scm		\
@@ -500,6 +501,7 @@ SCM_TESTS =					\
   tests/swh.scm				\
   tests/syscalls.scm				\
   tests/system.scm				\
+  tests/style.scm				\
   tests/texlive.scm				\
   tests/transformations.scm			\
   tests/ui.scm					\
diff --git a/doc/guix.texi b/doc/guix.texi
index e0a56a6bc0..c0d456c8ea 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -286,6 +286,7 @@ Utilities
 * Invoking guix hash::          Computing the cryptographic hash of a file.
 * Invoking guix import::        Importing package definitions.
 * Invoking guix refresh::       Updating package definitions.
+* Invoking guix style::         Styling package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix size::          Profiling disk usage.
 * Invoking guix graph::         Visualizing the graph of packages.
@@ -6722,7 +6723,8 @@ the one above, but using the @dfn{old input style}:
 
 This style is now deprecated; it is still supported but support will be
 removed in a future version.  It should not be used for new package
-definitions.
+definitions.  @xref{Invoking guix style}, on how to migrate to the new
+style.
 @end quotation
 
 @cindex cross compilation, package dependencies
@@ -10254,6 +10256,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix hash::          Computing the cryptographic hash of a file.
 * Invoking guix import::        Importing package definitions.
 * Invoking guix refresh::       Updating package definitions.
+* Invoking guix style::         Styling package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix size::          Profiling disk usage.
 * Invoking guix graph::         Visualizing the graph of packages.
@@ -12076,6 +12079,98 @@ token procured from @uref{https://github.com/settings/tokens} or
 otherwise.
 
 
+@node Invoking guix style
+@section Invoking @command{guix style}
+
+The @command{guix style} command helps packagers style their package
+definitions according to the latest fashionable trends.  The command
+currently focuses on one aspect: the style of package inputs.  It may
+eventually be extended to handle other stylistic matters.
+
+The way package inputs are written is going through a transition
+(@pxref{package Reference}, for more on package inputs).  Until version
+1.3.0, package inputs were written using the ``old style'', where each
+input was given an explicit label, most of the time the package name:
+
+@lisp
+(package
+  ;; @dots{}
+  ;; The "old style" (deprecated).
+  (inputs `(("libunistring" ,libunistring)
+            ("libffi" ,libffi))))
+@end lisp
+
+Today, the old style is deprecated and the preferred style looks like
+this:
+
+@lisp
+(package
+  ;; @dots{}
+  ;; The "new style".
+  (inputs (list libunistring libffi)))
+@end lisp
+
+Likewise, uses of @code{alist-delete} and friends to manipulate inputs
+is now deprecated in favor of @code{modify-inputs} (@pxref{Defining
+Package Variants}, for more info on @code{modify-inputs}).
+
+In the vast majority of cases, this is a purely mechanical change on the
+surface syntax that does not even incur a package rebuild.  Running
+@command{guix style} can do that for you, whether you're working on
+packages in Guix proper or in an external channel.
+
+The general syntax is:
+
+@example
+guix style [@var{options}] @var{package}@dots{}
+@end example
+
+This causes @command{guix style} to analyze and rewrite the definition
+of @var{package}@dots{}.  It does so in a conservative way: preserving
+comments and bailing out if it cannot make sense of the code that
+appears in an inputs field.  The available options are listed below.
+
+@table @code
+@item --load-path=@var{directory}
+@itemx -L @var{directory}
+Add @var{directory} to the front of the package module search path
+(@pxref{Package Modules}).
+
+@item --expression=@var{expr}
+@itemx -e @var{expr}
+Style the package @var{expr} evaluates to.
+
+For example, running:
+
+@example
+guix style -e '(@@ (gnu packages gcc) gcc-5)'
+@end example
+
+styles the @code{gcc-5} package definition.
+
+@item --input-simplification=@var{policy}
+Specify the package input simplification policy for cases where an input
+label does not match the corresponding package name.  @var{policy} may
+be one of the following:
+
+@table @code
+@item silent
+Simplify inputs only when the change is ``silent'', meaning that the
+package does not need to be rebuilt (its derivation is unchanged).
+
+@item safe
+Simplify inputs only when that is ``safe'' to do: the package might need
+to be rebuilt, but the change is known to have no observable effect.
+
+@item always
+Simplify inputs even when input labels do not match package names, and
+even if that might have an observable effect.
+@end table
+
+The default is @code{silent}, meaning that input simplifications do not
+trigger any package rebuild.
+@end table
+
 @node Invoking guix lint
 @section Invoking @command{guix lint}
 
@@ -12209,7 +12304,8 @@ use of tabulations, etc.
 Report old-style input labels that do not match the name of the
 corresponding package.  This aims to help migrate from the ``old input
 style''.  @xref{package Reference}, for more information on package
-inputs and input styles.
+inputs and input styles.  @xref{Invoking guix style}, on how to migrate
+to the new style.
 @end table
 
 The general syntax is:
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
new file mode 100644
index 0000000000..3c100197a7
--- /dev/null
+++ b/guix/scripts/style.scm
@@ -0,0 +1,527 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This script updates package definitions so they use the "simplified" style
+;;; for input lists, as in:
+;;;
+;;;  (package
+;;;    ;; ...
+;;;    (inputs (list foo bar baz)))
+;;;
+;;; Code:
+
+(define-module (guix scripts style)
+  #:autoload   (gnu packages) (specification->package fold-packages)
+  #:use-module (guix scripts)
+  #:use-module ((guix scripts build) #:select (%standard-build-options))
+  #:use-module (guix combinators)
+  #:use-module (guix ui)
+  #:use-module (guix packages)
+  #:use-module (guix utils)
+  #:use-module (guix i18n)
+  #:use-module (guix diagnostics)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:export (guix-style))
+
+
+;;;
+;;; Comment-preserving reader.
+;;;
+
+;; A comment.
+(define-record-type <comment>
+  (comment str margin?)
+  comment?
+  (str     comment->string)
+  (margin? comment-margin?))
+
+(define (read-with-comments port)
+  "Like 'read', but include <comment> objects when they're encountered."
+  ;; Note: Instead of implementing this functionality in 'read' proper, which
+  ;; is the best approach long-term, this code is a later on top of 'read',
+  ;; such that we don't have to rely on a specific Guile version.
+  (let loop ((blank-line? #t)
+             (return (const 'unbalanced)))
+    (match (read-char port)
+      ((? eof-object? eof)
+       eof)                                       ;oops!
+      (chr
+       (cond ((eqv? chr #\newline)
+              (loop #t return))
+             ((char-set-contains? char-set:whitespace chr)
+              (loop blank-line? return))
+             ((memv chr '(#\( #\[))
+              (let/ec return
+                (let liip ((lst '()))
+                  (liip (cons (loop (match lst
+                                      (((? comment?) . _) #t)
+                                      (_ #f))
+                                    (lambda ()
+                                      (return (reverse lst))))
+                              lst)))))
+             ((memv chr '(#\) #\]))
+              (return))
+             ((eq? chr #\')
+              (list 'quote (loop #f return)))
+             ((eq? chr #\`)
+              (list 'quasiquote (loop #f return)))
+             ((eq? chr #\,)
+              (list (match (peek-char port)
+                      (#\@
+                       (read-char port)
+                       'unquote-splicing)
+                      (_
+                       'unquote))
+                    (loop #f return)))
+             ((eqv? chr #\;)
+              (unread-char chr port)
+              (comment (read-line port 'concat)
+                       (not blank-line?)))
+             (else
+              (unread-char chr port)
+              (read port)))))))
+
+
+;;;
+;;; Comment-preserving pretty-printer.
+;;;
+
+(define* (pretty-print-with-comments port obj
+                                     #:key
+                                     (indent 0)
+                                     (max-width 78)
+                                     (long-list 5))
+  (let loop ((indent indent)
+             (column indent)
+             (delimited? #t)                  ;true if comes after a delimiter
+             (obj obj))
+    (match obj
+      ((? comment? comment)
+       (if (comment-margin? comment)
+           (begin
+             (display " " port)
+             (display (comment->string comment) port))
+           (begin
+             ;; When already at the beginning of a line, for example because
+             ;; COMMENT follows a margin comment, no need to emit a newline.
+             (unless (= column indent)
+               (newline port)
+               (display (make-string indent #\space) port))
+             (display (comment->string comment) port)))
+       (display (make-string indent #\space) port)
+       indent)
+      (('quote lst)
+       (unless delimited? (display " " port))
+       (display "'" port)
+       (loop indent (+ column (if delimited? 1 2)) #t lst))
+      (('quasiquote lst)
+       (unless delimited? (display " " port))
+       (display "`" port)
+       (loop indent (+ column (if delimited? 1 2)) #t lst))
+      (('unquote lst)
+       (unless delimited? (display " " port))
+       (display "," port)
+       (loop indent (+ column (if delimited? 1 2)) #t lst))
+      (('modify-inputs inputs clauses ...)
+       ;; Special-case 'modify-inputs' to have one clause per line and custom
+       ;; indentation.
+       (let ((head "(modify-inputs "))
+         (display head port)
+         (loop (+ indent 4)
+               (+ column (string-length head))
+               #t
+               inputs)
+         (let* ((indent (+ indent 2))
+                (column (fold (lambda (clause column)
+                                (newline port)
+                                (display (make-string indent #\space)
+                                         port)
+                                (loop indent indent #t clause))
+                              indent
+                              clauses)))
+           (display ")" port)
+           (+ column 1))))
+      ((head tail ...)
+       (unless delimited? (display " " port))
+       (display "(" port)
+       (let* ((new-column (loop indent (+ 1 column) #t head))
+              (indent (+ indent (- new-column column)))
+              (long?  (> (length tail) long-list)))
+         (define column
+           (fold2 (lambda (item column first?)
+                    (define newline?
+                      ;; Insert a newline if ITEM is itself a list, or if TAIL
+                      ;; is long, but only if ITEM is not the first item.
+                      (and (or (pair? item) long?)
+                           (not first?) (not (comment? item))))
+
+                    (when newline?
+                      (newline port)
+                      (display (make-string indent #\space) port))
+                    (let ((column (if newline? indent column)))
+                      (values (loop indent
+                                    column
+                                    (= column indent)
+                                    item)
+                              (comment? item))))
+                  (+ 1 new-column)
+                  #t                              ;first
+                  tail))
+         (display ")" port)
+         (+ column 1)))
+      (_
+       (let* ((str (object->string obj))
+              (len (string-length str)))
+         (if (> (+ column 1 len) max-width)
+             (begin
+               (newline port)
+               (display (make-string indent #\space) port)
+               (display str port)
+               (+ indent len))
+             (begin
+               (unless delimited? (display " " port))
+               (display str port)
+               (+ column (if delimited? 1 2) len))))))))
+
+(define (object->string* obj indent)
+  (call-with-output-string
+    (lambda (port)
+      (pretty-print-with-comments port obj
+                                  #:indent indent))))
+
+
+;;;
+;;; Simplifying input expressions.
+;;;
+
+(define (label-matches? label name)
+  "Return true if LABEL matches NAME, a package name."
+  (or (string=? label name)
+      (and (string-prefix? "python-" label)
+           (string-prefix? "python2-" name)
+           (string=? (string-drop label (string-length "python-"))
+                     (string-drop name (string-length "python2-"))))))
+
+(define* (simplify-inputs location package str inputs
+                          #:key (label-matches? label-matches?))
+  "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current
+value is INPUTS the corresponding source code is STR.  Return a string to
+replace STR."
+  (define (simplify-input-expression return)
+    (match-lambda
+      ((label ('unquote symbol)) symbol)
+      ((label ('unquote symbol) output)
+       (list 'quasiquote
+             (list (list 'unquote symbol) output)))
+      (_
+       ;; Expression doesn't look like a simple input.
+       (warning location (G_ "~a: complex expression, \
+bailing out~%")
+                package)
+       (return str))))
+
+  (define (simplify-input exp input return)
+    (define package* package)
+
+    (match input
+      ((or ((? string? label) (? package? package))
+           ((? string? label) (? package? package)
+            (? string?)))
+       ;; If LABEL doesn't match PACKAGE's name, then simplifying would incur
+       ;; a rebuild, and perhaps it would break build-side code relying on
+       ;; this specific label.
+       (if (label-matches? label (package-name package))
+           ((simplify-input-expression return) exp)
+           (begin
+             (warning location (G_ "~a: input label \
+'~a' does not match package name, bailing out~%")
+                      package* label)
+             (return str))))
+      (_
+       (warning location (G_ "~a: non-trivial input, \
+bailing out~%")
+                package*)
+       (return str))))
+
+  (define (simplify-expressions exp inputs return)
+    ;; Simplify the expressions in EXP, which correspond to INPUTS, and return
+    ;; a list of expressions.  Call RETURN with a string when bailing out.
+    (let loop ((result '())
+               (exp exp)
+               (inputs inputs))
+      (match exp
+        (((? comment? head) . rest)
+         (loop (cons head result) rest inputs))
+        ((head . rest)
+         (match inputs
+           ((input . inputs)
+            ;; HEAD (an sexp) and INPUT (an input tuple) are correlated.
+            (loop (cons (simplify-input head input return) result)
+                  rest inputs))
+           (()
+            ;; If EXP and INPUTS have a different length, that
+            ;; means EXP is a non-trivial input list, for example
+            ;; with input-splicing, conditionals, etc.
+            (warning location (G_ "~a: input expression is too short~%")
+                     package)
+            (return str))))
+        (()
+         ;; It's possible for EXP to contain fewer elements than INPUTS, for
+         ;; example in the case of input splicing.  No bailout here.  (XXX)
+         (reverse result)))))
+
+  (define inputs-exp
+    (call-with-input-string str read-with-comments))
+
+  (match inputs-exp
+    (('list _ ...)                                ;already done
+     str)
+    (('modify-inputs _ ...)                       ;already done
+     str)
+    (('quasiquote                                 ;prepending inputs
+      (exp ...
+           ('unquote-splicing
+            ((and symbol (or 'package-inputs 'package-native-inputs
+                             'package-propagated-inputs))
+             arg))))
+     (let/ec return
+       (object->string*
+        (let ((things (simplify-expressions exp inputs return)))
+          `(modify-inputs (,symbol ,arg)
+                          (prepend ,@things)))
+        (location-column location))))
+    (('quasiquote                                 ;replacing an input
+      ((and exp ((? string? to-delete) ('unquote replacement)))
+       ('unquote-splicing
+        ('alist-delete (? string? to-delete)
+                       ((and symbol
+                             (or 'package-inputs 'package-native-inputs
+                                 'package-propagated-inputs))
+                        arg)))))
+     (let/ec return
+       (object->string*
+        (let ((things (simplify-expressions (list exp)
+                                            (list (car inputs))
+                                            return)))
+          `(modify-inputs (,symbol ,arg)
+                          (replace ,to-delete ,replacement)))
+        (location-column location))))
+
+    (('quasiquote                                 ;removing an input
+      (exp ...
+           ('unquote-splicing
+            ('alist-delete (? string? to-delete)
+                           ((and symbol
+                                 (or 'package-inputs 'package-native-inputs
+                                     'package-propagated-inputs))
+                            arg)))))
+     (let/ec return
+       (object->string*
+        (let ((things (simplify-expressions exp inputs return)))
+          `(modify-inputs (,symbol ,arg)
+                          (delete ,to-delete)
+                          (prepend ,@things)))
+        (location-column location))))
+    (('fold 'alist-delete                         ;removing several inputs
+            ((and symbol
+                  (or 'package-inputs 'package-native-inputs
+                      'package-propagated-inputs))
+             arg)
+            ('quote ((? string? to-delete) ...)))
+     (object->string*
+      `(modify-inputs (,symbol ,arg)
+                      (delete ,@to-delete))
+      (location-column location)))
+    (('quasiquote                    ;removing several inputs and adding others
+      (exp ...
+           ('unquote-splicing
+            ('fold 'alist-delete
+                   ((and symbol
+                         (or 'package-inputs 'package-native-inputs
+                             'package-propagated-inputs))
+                    arg)
+                   ('quote ((? string? to-delete) ...))))))
+     (let/ec return
+       (object->string*
+        (let ((things (simplify-expressions exp inputs return)))
+          `(modify-inputs (,symbol ,arg)
+                          (delete ,@to-delete)
+                          (prepend ,@things)))
+        (location-column location))))
+    (('quasiquote (exp ...))
+     (let/ec return
+       (object->string*
+        `(list ,@(simplify-expressions exp inputs return))
+        (location-column location))))
+    (_
+     (warning location (G_ "~a: unsupported input style, \
+bailing out~%")
+              package)
+     str)))
+
+(define* (simplify-package-inputs package
+                                  #:key (policy 'silent))
+  "Edit the source code of PACKAGE to simplify its inputs field if needed.
+POLICY is a symbol that defines whether to simplify inputs; it can one of
+'silent (change only if the resulting derivation is the same), 'safe (change
+only if semantics are known to be unaffected), and 'always (fearlessly
+simplify inputs!)."
+  (for-each (lambda (field-name field)
+              (match (field package)
+                (()
+                 #f)
+                (inputs
+                 (match (package-field-location package field-name)
+                   (#f
+                    ;; If the location of FIELD-NAME is not found, it may be
+                    ;; that PACKAGE inherits from another package.
+                    #f)
+                   (location
+                    (edit-expression
+                     (location->source-properties location)
+                     (lambda (str)
+                       (define matches?
+                         (match policy
+                           ('silent
+                            ;; Simplify inputs only when the label matches
+                            ;; perfectly, such that the resulting derivation
+                            ;; is unchanged.
+                            label-matches?)
+                           ('safe
+                            ;; If PACKAGE has no arguments, labels are known
+                            ;; to have no effect: this is a "safe" change, but
+                            ;; it may change the derivation.
+                            (if (null? (package-arguments package))
+                                (const #t)
+                                label-matches?))
+                           ('always
+                            ;; Assume it's gonna be alright.
+                            (const #f))))
+
+                       (simplify-inputs location
+                                        (package-name package)
+                                        str inputs
+                                        #:label-matches? matches?))))))))
+            '(inputs native-inputs propagated-inputs)
+            (list package-inputs package-native-inputs
+                  package-propagated-inputs)))
+
+(define (package-location<? p1 p2)
+  "Return true if P1's location is \"before\" P2's."
+  (let ((loc1 (package-location p1))
+        (loc2 (package-location p2)))
+    (and loc1 loc2
+         (if (string=? (location-file loc1) (location-file loc2))
+             (< (location-line loc1) (location-line loc2))
+             (string<? (location-file loc1) (location-file loc2))))))
+
+
+;;;
+;;; Options.
+;;;
+
+(define %options
+  ;; Specification of the command-line options.
+  (list (find (lambda (option)
+                (member "load-path" (option-names option)))
+              %standard-build-options)
+
+        (option '(#\e "expression") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'expression arg result)))
+        (option '("input-simplification") #t #f
+                (lambda (opt name arg result)
+                  (let ((symbol (string->symbol arg)))
+                    (unless (memq symbol '(silent safe always))
+                      (leave (G_ "~a: invalid input simplification policy~%")
+                             arg))
+                    (alist-cons 'input-simplification-policy symbol
+                                result))))
+
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix style")))))
+
+(define (show-help)
+  (display (G_ "Usage: guix style [OPTION]... [PACKAGE]...
+Update package definitions to the latest style.\n"))
+  (display (G_ "
+  -L, --load-path=DIR    prepend DIR to the package module search path"))
+  (display (G_ "
+  -e, --expression=EXPR  consider the package EXPR evaluates to"))
+  (display (G_ "
+      --input-simplification=POLICY
+                         follow POLICY for package input simplification, one
+                         of 'silent', 'safe', or 'always'"))
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %default-options
+  ;; Alist of default option values.
+  '((input-simplification-policy . silent)))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define-command (guix-style . args)
+  (category packaging)
+  (synopsis "update the style of package definitions")
+
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
+
+  (let* ((opts     (parse-options))
+         (packages (filter-map (match-lambda
+                                 (('argument . spec)
+                                  (specification->package spec))
+                                 (('expression . str)
+                                  (read/eval str))
+                                 (_ #f))
+                               opts))
+         (policy   (assoc-ref opts 'input-simplification-policy)))
+    (for-each (lambda (package)
+                (simplify-package-inputs package #:policy policy))
+              ;; Sort package by source code location so that we start editing
+              ;; files from the bottom and going upward.  That way, the
+              ;; 'location' field of <package> records is not invalidated as
+              ;; we modify files.
+              (sort (if (null? packages)
+                        (fold-packages cons '() #:select? (const #t))
+                        packages)
+                    (negate package-location<?)))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 14324b25de..6a55046531 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -115,5 +115,6 @@ guix/scripts/offload.scm
 guix/scripts/perform-download.scm
 guix/scripts/refresh.scm
 guix/scripts/repl.scm
+guix/scripts/style.scm
 guix/scripts/system/reconfigure.scm
 nix/nix-daemon/guix-daemon.cc
diff --git a/tests/style.scm b/tests/style.scm
new file mode 100644
index 0000000000..ada9197fc1
--- /dev/null
+++ b/tests/style.scm
@@ -0,0 +1,366 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests-style)
+  #:use-module (guix packages)
+  #:use-module (guix scripts style)
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module ((guix build utils) #:select (substitute*))
+  #:use-module (guix diagnostics)
+  #:use-module (gnu packages acl)
+  #:use-module (gnu packages multiprecision)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 pretty-print))
+
+(define (call-with-test-package inputs proc)
+  (call-with-temporary-directory
+   (lambda (directory)
+     (call-with-output-file (string-append directory "/my-packages.scm")
+       (lambda (port)
+         (pretty-print
+          `(begin
+             (define-module (my-packages)
+               #:use-module (guix)
+               #:use-module (guix licenses)
+               #:use-module (gnu packages acl)
+               #:use-module (gnu packages base)
+               #:use-module (gnu packages multiprecision)
+               #:use-module (srfi srfi-1))
+
+             (define base
+               (package
+                 (inherit coreutils)
+                 (inputs '())
+                 (native-inputs '())
+                 (propagated-inputs '())))
+
+             (define (sdl-union . lst)
+               (package
+                 (inherit base)
+                 (name "sdl-union")))
+
+             (define-public my-coreutils
+               (package
+                 (inherit base)
+                 ,@inputs
+                 (name "my-coreutils"))))
+          port)))
+
+     (proc directory))))
+
+(define test-directory
+  ;; Directory where the package definition lives.
+  (make-parameter #f))
+
+(define-syntax-rule (with-test-package fields exp ...)
+  (call-with-test-package fields
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      ;; Run as a separate process to make sure FILE is reloaded.
+      (system* "guix" "style" "-L" directory "my-coreutils")
+      (system* "cat" file)
+
+      (load file)
+      (parameterize ((test-directory directory))
+        exp ...))))
+
+(define* (read-lines port line #:optional (count 1))
+  "Read COUNT lines from PORT, starting from LINE."
+  (let loop ((lines '())
+             (count count))
+    (cond ((< (port-line port) (- line 1))
+           (read-char port)
+           (loop lines count))
+          ((zero? count)
+           (string-concatenate-reverse lines))
+          (else
+           (match (read-line port 'concat)
+             ((? eof-object?)
+              (loop lines 0))
+             (line
+              (loop (cons line lines) (- count 1))))))))
+
+(define* (read-package-field package field #:optional (count 1))
+  (let* ((location (package-field-location package field))
+         (file (location-file location))
+         (line (location-line location)))
+    (call-with-input-file (if (string-prefix? "/" file)
+                              file
+                              (string-append (test-directory) "/"
+                                             file))
+      (lambda (port)
+        (read-lines port line count)))))
+
+
+(test-begin "style")
+
+(test-equal "nothing to rewrite"
+  '()
+  (with-test-package '()
+    (package-direct-inputs (@ (my-packages) my-coreutils))))
+
+(test-equal "input labels, mismatch"
+  (list `(("foo" ,gmp) ("bar" ,acl))
+        "      (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
+  (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
+    (list (package-direct-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, simple"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "      (inputs (list gmp acl))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
+    (list (package-direct-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, long list with one item per line"
+  (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
+        "\
+        (list gmp
+              acl
+              gmp
+              acl
+              gmp
+              acl
+              gmp
+              acl))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+                                 ("gmp" ,gmp) ("acl" ,acl)
+                                 ("gmp" ,gmp) ("acl" ,acl)
+                                 ("gmp" ,gmp) ("acl" ,acl))))
+    (list (package-direct-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
+
+(test-equal "input labels, sdl-union"
+  "\
+        (list gmp acl
+              (sdl-union 1 2 3 4)))\n"
+  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+                                 ("sdl-union" ,(sdl-union 1 2 3 4)))))
+    (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
+
+(test-equal "input labels, output"
+  (list `(("gmp" ,gmp "debug") ("acl" ,acl))
+        "      (inputs (list `(,gmp \"debug\") acl))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
+    (list (package-direct-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, prepend"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "\
+        (modify-inputs (package-propagated-inputs coreutils)
+          (prepend gmp acl)))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+                                 ,@(package-propagated-inputs coreutils))))
+    (list (package-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
+
+(test-equal "input labels, prepend + delete"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "\
+        (modify-inputs (package-propagated-inputs coreutils)
+          (delete \"gmp\")
+          (prepend gmp acl)))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp)
+                                 ("acl" ,acl)
+                                 ,@(alist-delete "gmp"
+                                                 (package-propagated-inputs coreutils)))))
+    (list (package-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
+
+(test-equal "input labels, prepend + delete multiple"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "\
+        (modify-inputs (package-propagated-inputs coreutils)
+          (delete \"foo\" \"bar\" \"baz\")
+          (prepend gmp acl)))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp)
+                                 ("acl" ,acl)
+                                 ,@(fold alist-delete
+                                         (package-propagated-inputs coreutils)
+                                         '("foo" "bar" "baz")))))
+    (list (package-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
+
+(test-equal "input labels, replace"
+  (list '()                                 ;there's no "gmp" input to replace
+        "\
+        (modify-inputs (package-propagated-inputs coreutils)
+          (replace \"gmp\" gmp)))\n")
+  (with-test-package '((inputs `(("gmp" ,gmp)
+                                 ,@(alist-delete "gmp"
+                                                 (package-propagated-inputs coreutils)))))
+    (list (package-inputs (@ (my-packages) my-coreutils))
+          (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
+
+(test-equal "input labels, 'safe' policy"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "\
+      (inputs (list gmp acl))\n")
+  (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
+                            (arguments '()))      ;no build system arguments
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (system* "guix" "style" "-L" directory "my-coreutils"
+               "--input-simplification=safe")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
+
+(test-equal "input labels, 'safe' policy, nothing changed"
+  (list `(("GMP" ,gmp) ("ACL" ,acl))
+        "\
+      (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
+  (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
+                            ;; Non-empty argument list, so potentially unsafe
+                            ;; input simplification.
+                            (arguments
+                             '(#:configure-flags
+                               (assoc-ref %build-inputs "GMP"))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (system* "guix" "style" "-L" directory "my-coreutils"
+               "--input-simplification=safe")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
+
+(test-equal "input labels, margin comment"
+  (list `(("gmp" ,gmp))
+        `(("acl" ,acl))
+        "      (inputs (list gmp)) ;margin comment\n"
+        "      (native-inputs (list acl)) ;another one\n")
+  (call-with-test-package '((inputs `(("gmp" ,gmp)))
+                            (native-inputs `(("acl" ,acl))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (substitute* file
+        (("\"gmp\"(.*)$" _ rest)
+         (string-append "\"gmp\"" (string-trim-right rest)
+                        " ;margin comment\n"))
+        (("\"acl\"(.*)$" _ rest)
+         (string-append "\"acl\"" (string-trim-right rest)
+                        " ;another one\n")))
+      (system* "cat" file)
+
+      (system* "guix" "style" "-L" directory "my-coreutils")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (package-native-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs)
+            (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
+
+(test-equal "input labels, margin comment on long list"
+  (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
+        "\
+        (list gmp ;margin comment
+              acl
+              gmp ;margin comment
+              acl
+              gmp ;margin comment
+              acl
+              gmp ;margin comment
+              acl))\n")
+  (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+                                      ("gmp" ,gmp) ("acl" ,acl)
+                                      ("gmp" ,gmp) ("acl" ,acl)
+                                      ("gmp" ,gmp) ("acl" ,acl))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (substitute* file
+        (("\"gmp\"(.*)$" _ rest)
+         (string-append "\"gmp\"" (string-trim-right rest)
+                        " ;margin comment\n")))
+      (system* "cat" file)
+
+      (system* "guix" "style" "-L" directory "my-coreutils")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
+
+(test-equal "input labels, line comment"
+  (list `(("gmp" ,gmp) ("acl" ,acl))
+        "\
+      (inputs (list gmp
+                    ;; line comment!
+                    acl))\n")
+  (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (substitute* file
+        ((",gmp\\)(.*)$" _ rest)
+         (string-append ",gmp)\n   ;; line comment!\n" rest)))
+
+      (system* "guix" "style" "-L" directory "my-coreutils")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
+
+(test-equal "input labels, modify-inputs and margin comment"
+  (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
+        "\
+        (modify-inputs (package-propagated-inputs coreutils)
+          (prepend gmp ;margin comment
+                   acl ;another one
+                   mpfr)))\n")
+  (call-with-test-package '((inputs
+                             `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
+                               ,@(package-propagated-inputs coreutils))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+
+      (substitute* file
+        ((",gmp\\)(.*)$" _ rest)
+         (string-append ",gmp) ;margin comment\n" rest))
+        ((",acl\\)(.*)$" _ rest)
+         (string-append ",acl) ;another one\n" rest)))
+
+      (system* "guix" "style" "-L" directory "my-coreutils")
+
+      (load file)
+      (list (package-inputs (@ (my-packages) my-coreutils))
+            (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
+
+(test-end)
+
+;; Local Variables:
+;; eval: (put 'with-test-package 'scheme-indent-function 1)
+;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
+;; End: