[bug#52974] [PATCH 3/5] style: Add support for "newline forms".

["Ludovic Courtès" <ludo@gnu.org>]

This allows us to express cases where a newline should be inserted
immediately after the head symbol of a list.

* guix/scripts/style.scm (%newline-forms): New variable.
(newline-form?): New procedure.
(pretty-print-with-comments): Handle "newline forms".
* tests/style.scm: Add test.
---
 guix/scripts/style.scm | 40 +++++++++++++++++++++++++++++++++++-----
 tests/style.scm        | 13 +++++++++++++
 2 files changed, 48 insertions(+), 5 deletions(-)

diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 625e942613..00680daa23 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -163,6 +163,18 @@ (define %special-forms
    ('with-output-to-file 2)
    ('with-input-from-file 2)))
 
+(define %newline-forms
+  ;; List heads that must be followed by a newline.  The second argument is
+  ;; the context in which they must appear.  This is similar to a special form
+  ;; of 1, except that indent is 1 instead of 2 columns.
+  (vhashq
+   ('arguments '(package))
+   ('sha256 '(origin source package))
+   ('base32 '(sha256 origin))
+   ('search-paths '(package))
+   ('native-search-paths '(package))
+   ('search-path-specification '())))
+
 (define (prefix? candidate lst)
   "Return true if CANDIDATE is a prefix of LST."
   (let loop ((candidate candidate)
@@ -188,6 +200,14 @@ (define (special-form-lead symbol context)
              (and (prefix? prefix context) (- level 1))))
           alist))))
 
+(define (newline-form? symbol context)
+  "Return true if parenthesized expressions starting with SYMBOL must be
+followed by a newline."
+  (match (vhash-assq symbol %newline-forms)
+    (#f #f)
+    ((_ . prefix)
+     (prefix? prefix context))))
+
 (define (escaped-string str)
   "Return STR with backslashes and double quotes escaped.  Everything else, in
 particular newlines, is left as is."
@@ -377,6 +397,7 @@ (define new-column
               (column    (if overflow?
                              (+ indent 1)
                              (+ column (if delimited? 1 2))))
+              (newline?  (newline-form? head context))
               (context   (cons head context)))
          (if overflow?
              (begin
@@ -384,17 +405,26 @@ (define new-column
                (display (make-string indent #\space) port))
              (unless delimited? (display " " port)))
          (display "(" port)
+
          (let* ((new-column (loop column column #t context head))
                 (indent (if (or (>= new-column max-width)
                                 (not (symbol? head))
                                 (sequence-would-protrude?
-                                 (+ new-column 1) tail))
+                                 (+ new-column 1) tail)
+                                newline?)
                             column
                             (+ new-column 1))))
-           (define column
-             (print-sequence context indent new-column tail #f))
-           (display ")" port)
-           (+ column 1))))
+           (when newline?
+             ;; Insert a newline right after HEAD.
+             (newline port)
+             (display (make-string indent #\space) port))
+
+           (let ((column
+                  (print-sequence context indent
+                                  (if newline? indent new-column)
+                                  tail newline?)))
+             (display ")" port)
+             (+ column 1)))))
       (_
        (let* ((str (if (string? obj)
                        (escaped-string obj)
diff --git a/tests/style.scm b/tests/style.scm
index 6c449cb72e..8022688419 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -465,6 +465,19 @@ (define file
   ;; Regular indentation for 'replace' here.
   (replace \"gmp\" gmp))")
 
+(test-pretty-print "\
+(package
+  ;; Here 'sha256', 'base32', and 'arguments' must be
+  ;; immediately followed by a newline.
+  (source (origin
+            (method url-fetch)
+            (sha256
+             (base32
+              \"not a real base32 string\"))))
+  (arguments
+   '(#:phases %standard-phases
+     #:tests? #f)))")
+
 (test-end)
 
 ;; Local Variables:
-- 
2.33.0