From ba5da5125a81307500982517e2f458d57b024668 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 5 May 2023 17:34:01 +0200 Subject: [PATCH] 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 @@ (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 matches? (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 file (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)