14/15: style: Add 'arguments' styling rule.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ba5da5125a81307500982517e2f458d57b024668
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 5 17:34:01 2023 +0200

    style: Add 'arguments' styling rule.
    
    * guix/scripts/style.scm (unquote->ungexp, gexpify-argument-value)
    (quote-argument-value, gexpify-argument-tail)
    (gexpify-package-arguments): New procedures.
    (%gexp-keywords): New variable.
    (%options): Add "arguments" case for 'styling-procedure.
    (show-stylings): Update.
    * tests/style.scm ("gexpify arguments, already gexpified")
    ("gexpify arguments, non-gexp arguments, margin comment")
    ("gexpify arguments, phases and flags")
    ("gexpify arguments, append arguments")
    ("gexpify arguments, substitute-keyword-arguments")
    ("gexpify arguments, append substitute-keyword-arguments"): New tests.
    * doc/guix.texi (package Reference): For 'arguments', add compatibility
    note and link to 'guix style'.
    (Invoking guix style): Document the 'arguments' styling rule.
---
 doc/guix.texi          |  51 +++++++++++++++
 guix/scripts/style.scm | 173 ++++++++++++++++++++++++++++++++++++++++++++++++-
 tests/style.scm        | 136 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 359 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5851af4092..b40870f42b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7785,6 +7785,24 @@ The exact set of supported keywords depends on the build 
system
 @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{'()})
@@ -14709,6 +14727,39 @@ Rewriting is done in a conservative way: preserving 
comments and bailing
 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 @@
   #: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))
@@ -303,6 +304,174 @@ PACKAGE."
                   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 @@ PACKAGE."
                   (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 @@ PACKAGE."
 (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 @@
       (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)