me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2021-06-17 22:36:59 +02:00
parent 73b08ad1a3
commit f23803af20
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 994 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -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 \

100
doc/guix.texi
View File

@ -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:

527
guix/scripts/style.scm 100644
View File

@ -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<?)))))

1
po/guix/POTFILES.in
View File

@ -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

366
tests/style.scm 100644
View File

@ -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: