diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 100 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 527 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/style.scm | 366 |
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: |