Toggle diff (423 lines)
diff --git a/doc/guix.texi b/doc/guix.texi
index 55221a10c3..12d7e02bca 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7743,6 +7743,24 @@ package Reference
@code{#:phases}. The @code{#:phases} keyword in particular lets you
modify the set of build phases for your package (@pxref{Build Phases}).
+@quotation Compatibility Note
+Until version 1.3.0, the @code{arguments} field would typically use
+@code{quote} (@code{'}) or @code{quasiquote} (@code{`}) and no
+G-expressions, like so:
+
+@lisp
+(package
+ ;; several fields omitted
+ (arguments ;old-style quoted arguments
+ '(#:tests? #f
+ #:configure-flags '("--enable-frobbing"))))
+@end lisp
+
+To convert from that style to the one shown above, you can run
+@code{guix style -S arguments @var{package}} (@pxref{Invoking guix
+style}).
+@end quotation
+
@item @code{inputs} (default: @code{'()})
@itemx @code{native-inputs} (default: @code{'()})
@itemx @code{propagated-inputs} (default: @code{'()})
@@ -14657,6 +14675,39 @@ Invoking guix style
out if it cannot make sense of the code that appears in an inputs field.
The @option{--input-simplification} option described below provides
fine-grain control over when inputs should be simplified.
+
+@item arguments
+Rewrite package arguments to use G-expressions (@pxref{G-Expressions}).
+For example, consider this package definition:
+
+@lisp
+(define-public my-package
+ (package
+ ;; @dots{}
+ (arguments ;old-style quoted arguments
+ '(#:make-flags '("V=1")
+ #:phases (modify-phases %standard-phases
+ (delete 'build))))))
+@end lisp
+
+@noindent
+Running @command{guix style -S arguments} on this package would rewrite
+its @code{arguments} field like to:
+
+@lisp
+(define-public my-package
+ (package
+ ;; @dots{}
+ (arguments
+ (list #:make-flags #~'("V=1")
+ #:phases #~(modify-phases %standard-phases
+ (delete 'build))))))
+@end lisp
+
+Note that changes made by the @code{arguments} rule do not entail a
+rebuild of the affected packages. Furthermore, if a package definition
+happens to be using G-expressions already, @command{guix style} leaves
+it unchanged.
@end table
@item --list-stylings
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 00c7d3f90c..1d02742524 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -41,6 +41,7 @@ (define-module (guix scripts style)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:export (guix-style))
@@ -302,6 +303,174 @@ (define* (simplify-package-inputs package
(list package-inputs package-native-inputs
package-propagated-inputs)))
+
+;;;
+;;; Gexpifying package arguments.
+;;;
+
+(define (unquote->ungexp value)
+ "Replace 'unquote' and 'unquote-splicing' in VALUE with their gexp
+counterpart."
+ ;; Replace 'unquote only on the first quasiquotation level.
+ (let loop ((value value)
+ (quotation 1))
+ (match value
+ (('unquote x)
+ (if (= quotation 1)
+ `(ungexp ,x)
+ value))
+ (('unquote-splicing x)
+ (if (= quotation 1)
+ `(ungexp-splicing x)
+ value))
+ (('quasiquote x)
+ (list 'quasiquote (loop x (+ quotation 1))))
+ (('quote x)
+ (list 'quote (loop x (+ quotation 1))))
+ ((lst ...)
+ (map (cut loop <> quotation) lst))
+ (x x))))
+
+(define (gexpify-argument-value value quotation)
+ "Turn VALUE, an sexp, into its gexp equivalent. QUOTATION is a symbol that
+indicates in what quotation context VALUE is to be interpreted: 'quasiquote,
+'quote, or 'none."
+ (match quotation
+ ('none
+ (match value
+ (('quasiquote value)
+ (gexpify-argument-value value 'quasiquote))
+ (('quote value)
+ (gexpify-argument-value value 'quote))
+ (value value)))
+ ('quote
+ `(gexp ,value))
+ ('quasiquote
+ `(gexp ,(unquote->ungexp value)))))
+
+(define (quote-argument-value value quotation)
+ "Quote VALUE, an sexp. QUOTATION is a symbol that indicates in what
+quotation context VALUE is to be interpreted: 'quasiquote, 'quote, or 'none."
+ (define (self-quoting? x)
+ (or (boolean? x) (number? x) (string? x) (char? x)
+ (keyword? x)))
+
+ (match quotation
+ ('none
+ (match value
+ (('quasiquote value)
+ (quote-argument-value value 'quasiquote))
+ (('quote value)
+ (quote-argument-value value 'quote))
+ (value value)))
+ ('quote
+ (if (self-quoting? value)
+ value
+ (list 'quote value)))
+ ('quasiquote
+ (match value
+ (('unquote x) x)
+ ((? self-quoting? x) x)
+ (_ (list 'quasiquote value))))))
+
+(define %gexp-keywords
+ ;; Package argument keywords that must be followed by a gexp.
+ '(#:phases #:configure-flags #:make-flags #:strip-flags))
+
+(define (gexpify-argument-tail sexp)
+ "Gexpify SEXP, an unquoted argument tail."
+ (match sexp
+ (('substitute-keyword-arguments lst clauses ...)
+ `(substitute-keyword-arguments ,lst
+ ,@(map (match-lambda
+ ((((? keyword? keyword) identifier) body)
+ `((,keyword ,identifier)
+ ,(if (memq keyword %gexp-keywords)
+ (gexpify-argument-value body 'none)
+ (quote-argument-value body 'none))))
+ ((((? keyword? keyword) identifier default) body)
+ `((,keyword ,identifier
+ ,(if (memq keyword %gexp-keywords)
+ (gexpify-argument-value default 'none)
+ (quote-argument-value default 'none)))
+ ,(if (memq keyword %gexp-keywords)
+ (gexpify-argument-value body 'none)
+ (quote-argument-value body 'none))))
+ (clause clause))
+ clauses)))
+ (_ sexp)))
+
+(define* (gexpify-package-arguments package
+ #:key
+ (policy 'none)
+ (edit-expression edit-expression))
+ "Rewrite the 'arguments' field of PACKAGE to use gexps where applicable."
+ (define (gexpify location str)
+ (match (call-with-input-string str read-with-comments)
+ ((rest ...)
+ (let ((blanks (take-while blank? rest))
+ (value (drop-while blank? rest)))
+ (define-values (quotation arguments tail)
+ (match value
+ (('quote (arguments ...)) (values 'quote arguments '()))
+ (('quasiquote (arguments ... ('unquote-splicing tail)))
+ (values 'quasiquote arguments tail))
+ (('quasiquote (arguments ...)) (values 'quasiquote arguments '()))
+ (('list arguments ...) (values 'none arguments '()))
+ (arguments (values 'none '() arguments))))
+
+ (define (append-tail sexp)
+ (if (null? tail)
+ sexp
+ (let ((tail (gexpify-argument-tail tail)))
+ (if (null? arguments)
+ tail
+ `(append ,sexp ,tail)))))
+
+ (let/ec return
+ (object->string*
+ (append-tail
+ `(list ,@(let loop ((arguments arguments)
+ (result '()))
+ (match arguments
+ (() (reverse result))
+ (((? keyword? keyword) value rest ...)
+ (when (eq? quotation 'none)
+ (match value
+ (('gexp _) ;already gexpified
+ (return str))
+ (_ #f)))
+
+ (loop rest
+ (cons* (if (memq keyword %gexp-keywords)
+ (gexpify-argument-value value
+ quotation)
+ (quote-argument-value value quotation))
+ keyword result)))
+ (((? blank? blank) rest ...)
+ (loop rest (cons blank result)))
+ (_
+ ;; Something like: ,@(package-arguments xyz).
+ (warning location
+ (G_ "unsupported argument style; \
+bailing out~%"))
+ (return str))))))
+ (location-column location)))))
+ (_
+ (warning location
+ (G_ "unsupported argument field; bailing out~%"))
+ str)))
+
+ (unless (null? (package-arguments package))
+ (match (package-field-location package 'arguments)
+ (#f
+ #f)
+ (location
+ (edit-expression
+ (location->source-properties (absolute-location location))
+ (lambda (str)
+ (gexpify location str)))))))
+
;;;
;;; Formatting package definitions.
@@ -379,6 +548,7 @@ (define %options
(alist-cons 'styling-procedure
(match arg
("inputs" simplify-package-inputs)
+ ("arguments" gexpify-package-arguments)
("format" format-package-definition)
(_ (leave (G_ "~a: unknown styling~%")
arg)))
@@ -407,7 +577,8 @@ (define %options
(define (show-stylings)
(display (G_ "Available styling rules:\n"))
(display (G_ "- format: Format the given package definition(s)\n"))
- (display (G_ "- inputs: Rewrite package inputs to the “new style”\n")))
+ (display (G_ "- inputs: Rewrite package inputs to the “new style”\n"))
+ (display (G_ "- arguments: Rewrite package arguments to G-expressions\n")))
(define (show-help)
(display (G_ "Usage: guix style [OPTION]... [PACKAGE]...
diff --git a/tests/style.scm b/tests/style.scm
index f141a57d7f..5e38549606 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -386,6 +386,142 @@ (define* (read-package-field package field #:optional (count 1))
(list (package-inputs (@ (my-packages) my-coreutils))
(read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
+(test-assert "gexpify arguments, already gexpified"
+ (call-with-test-package '((arguments
+ (list #:configure-flags #~'("--help"))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+ (define (fingerprint file)
+ (let ((stat (stat file)))
+ (list (stat:mtime stat) (stat:size stat))))
+ (define before
+ (fingerprint file))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (equal? (fingerprint file) before))))
+
+(test-equal "gexpify arguments, non-gexp arguments, margin comment"
+ (list (list #:tests? #f #:test-target "check")
+ "\
+ (arguments (list #:tests? #f ;no tests
+ #:test-target \"check\"))\n")
+ (call-with-test-package '((arguments
+ '(#:tests? #f
+ #:test-target "check")))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ (("#:tests\\? #f" all)
+ (string-append all " ;no tests\n")))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (load file)
+ (list (package-arguments (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'arguments 2)))))
+
+(test-equal "gexpify arguments, phases and flags"
+ "\
+ (list #:tests? #f
+ #:configure-flags #~'(\"--fast\")
+ #:make-flags #~(list (string-append \"CC=\"
+ #$(cc-for-target)))
+ #:phases #~(modify-phases %standard-phases
+ ;; Line comment.
+ whatever)))\n"
+ (call-with-test-package '((arguments
+ `(#:tests? #f
+ #:configure-flags '("--fast")
+ #:make-flags
+ (list (string-append "CC=" ,(cc-for-target)))
+ #:phases (modify-phases %standard-phases
+ whatever))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ (("whatever")
+ "\n;; Line comment.
+ whatever"))
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (load file)
+ (read-package-field (@ (my-packages) my-coreutils) 'arguments 7))))
+
+(test-equal "gexpify arguments, append arguments"
+ "\
+ (append (list #:tests? #f
+ #:configure-flags #~'(\"--fast\"))
+ (package-arguments coreutils)))\n"
+ (call-with-test-package '((arguments
+ `(#:tests? #f
+ #:configure-flags '("--fast")
+ ,@(package-arguments coreutils))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (load file)
+ (read-package-field (@ (my-packages) my-coreutils) 'arguments 3))))
+
+(test-equal "gexpify arguments, substitute-keyword-arguments"
+ "\
+ (substitute-keyword-arguments (package-arguments coreutils)
+ ((#:tests? _ #f)
+ #t)
+ ((#:make-flags flags
+ #~'())
+ #~(cons \"-DXYZ=yes\"
+ #$flags))))\n"
+ (call-with-test-package '((arguments
+ (substitute-keyword-arguments
+ (package-arguments coreutils)
+ ((#:tests? _ #f) #t)
+ ((#:make-flags flags ''())
+ `(cons "-DXYZ=yes" ,flags)))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (load file)
+ (read-package-field (@ (my-packages) my-coreutils) 'arguments 7))))
+
+(test-equal "gexpify arguments, append substitute-keyword-arguments"
+ "\
+ (append (list #:tests? #f)
+ (substitute-keyword-arguments (package-arguments coreutils)
+ ((#:make-flags flags)
+ #~(append `(\"-n\" ,%output)
+ #$flags)))))\n"
+ (call-with-test-package '((arguments
+ `(#:tests? #f
+ ,@(substitute-keyword-arguments
+ (package-arguments coreutils)
+ ((#:make-flags flags)
+ `(append `("-n" ,%output) ,flags))))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "-S" "arguments")
+
+ (load file)
+ (read-package-field (@ (my-packages) my-coreutils) 'arguments 5))))
(test-end)
--
2.39.2
