@@ -285,6 +285,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 \
@@ -497,6 +498,7 @@ SCM_TESTS = \
tests/swh.scm \
tests/syscalls.scm \
tests/system.scm \
+ tests/style.scm \
tests/texlive.scm \
tests/transformations.scm \
tests/ui.scm \
@@ -284,6 +284,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.
@@ -6707,7 +6708,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
@@ -10234,6 +10236,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.
@@ -12032,6 +12035,64 @@ 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}).
+@end table
+
@node Invoking guix lint
@section Invoking @command{guix lint}
@@ -12165,7 +12226,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:
new file mode 100644
@@ -0,0 +1,475 @@
+;;; 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 #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
+ (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 (simplify-inputs location package str inputs)
+ "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 (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-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)
+ "Edit the source code of PACKAGE to simplify its inputs field if needed."
+ (for-each (lambda (field-name field)
+ (match (field package)
+ (()
+ #f)
+ (inputs
+ (match (package-field-location package field-name)
+ (#f
+ ;; (unless (null? (field package))
+ ;; (warning (package-location package)
+ ;; (G_ "source location not found for '~a' of '~a'~%")
+ ;; field-name (package-name package)))
+ #f)
+ (location
+ (edit-expression (location->source-properties location)
+ (lambda (str)
+ (simplify-inputs location
+ (package-name package)
+ str inputs))))))))
+ '(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 '(#\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"))
+ (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.
+ '())
+
+
+;;;
+;;; 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))
+ (specs (filter-map (match-lambda
+ (('argument . spec) spec)
+ (_ #f))
+ opts)))
+ (for-each simplify-package-inputs
+ ;; 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? specs)
+ (fold-packages cons '() #:select? (const #t))
+ (map specification->package specs))
+ (negate package-location<?)))))
@@ -112,5 +112,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
new file mode 100644
@@ -0,0 +1,328 @@
+;;; 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, 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: