[bug#56898] [PATCH 00/13] Put the pretty printer to good use

[bug#56898] [PATCH 00/13] Put the pretty printer to good use

[Ludovic Courtès]

Hello Guix!

I shaved a yak!  This patch series promotes the pretty reader/printer
of ‘guix style’ to its own module, improves it so it can deal with
vertical space, adds a ‘-f’ option to ‘guix style’ to reformat
whole files, changes the installer to use this pretty-printer, and
changes the installer so it emits comments and vertical space in
the generated configuration.

You can use ‘guix style -f’ on any Scheme file.  The pretty-printer
does a decent job, though there are still cases where it’s not as
good as my little hands at formatting things nicely.  For newcomers,
it should be very helpful.

Comments?  Vertical space?  Page breaks?

Ludo’.

Ludovic Courtès (13):
  style: Move reader and printer to (guix read-print).
  read-print: Add System and Home special forms.
  read-print: Expose comment constructor.
  read-print: Introduce <blank> parent class of <comment>.
  style: Adjust test to not emit blank lines.
  read-print: Read and render vertical space.
  read-print: Recognize page breaks.
  read-print: Add code to read and write sequences of
    expressions/blanks.
  read-print: 'canonicalize-comment' leaves top-level comments
    unchanged.
  style: Add '--whole-file' option.
  read-print: Support printing multi-line comments.
  installer: Render the final configuration with (guix read-print).
  installer: Add comments and vertical space to the generated config.

 Makefile.am                |   3 +
 doc/guix.texi              |  28 +-
 gnu/installer.scm          |   3 +-
 gnu/installer/parted.scm   |  10 +-
 gnu/installer/services.scm |  39 ++-
 gnu/installer/steps.scm    |  32 +-
 gnu/installer/user.scm     |   7 +-
 guix/read-print.scm        | 678 +++++++++++++++++++++++++++++++++++++
 guix/scripts/import.scm    |   4 +-
 guix/scripts/style.scm     | 527 +++-------------------------
 tests/guix-style.sh        |  80 +++++
 tests/read-print.scm       | 358 ++++++++++++++++++++
 tests/style.scm            | 185 +---------
 13 files changed, 1270 insertions(+), 684 deletions(-)
 create mode 100644 guix/read-print.scm
 create mode 100644 tests/guix-style.sh
 create mode 100644 tests/read-print.scm


base-commit: d7e7494bc4d69de9db49488ee812e572c3250211
-- 
2.37.1

[bug#56898] [PATCH 01/13] style: Move reader and printer to (guix read-print).

[Ludovic Courtès]

* guix/scripts/style.scm (<comment>, read-with-comments)
(vhashq, %special-forms, %newline-forms, prefix?)
(special-form-lead, newline-form?, escaped-string)
(string-width, canonicalize-comment, pretty-print-with-comments)
(object->string*): Move to...
* guix/read-print.scm: ... here.  New file.
* guix/scripts/import.scm: Adjust accordingly.
* tests/style.scm: Move 'test-pretty-print' and tests to...
* tests/read-print.scm: ... here.  New file.
* Makefile.am (MODULES): Add 'guix/read-print.scm'.
(SCM_TESTS): Add 'tests/read-print.scm'.
---
 Makefile.am             |   2 +
 guix/read-print.scm     | 490 ++++++++++++++++++++++++++++++++++++++++
 guix/scripts/import.scm |   4 +-
 guix/scripts/style.scm  | 457 +------------------------------------
 tests/read-print.scm    | 209 +++++++++++++++++
 tests/style.scm         | 181 ---------------
 6 files changed, 705 insertions(+), 638 deletions(-)
 create mode 100644 guix/read-print.scm
 create mode 100644 tests/read-print.scm

diff --git a/Makefile.am b/Makefile.am
index e5363140fb..2cda20e61c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -130,6 +130,7 @@ MODULES =					\
   guix/cve.scm					\
   guix/workers.scm				\
   guix/least-authority.scm			\
+  guix/read-print.scm				\
   guix/ipfs.scm					\
   guix/platform.scm                             \
   guix/platforms/arm.scm                        \
@@ -524,6 +525,7 @@ SCM_TESTS =					\
   tests/profiles.scm				\
   tests/publish.scm				\
   tests/pypi.scm				\
+  tests/read-print.scm				\
   tests/records.scm				\
   tests/scripts.scm				\
   tests/search-paths.scm			\
diff --git a/guix/read-print.scm b/guix/read-print.scm
new file mode 100644
index 0000000000..69ab8ac8b3
--- /dev/null
+++ b/guix/read-print.scm
@@ -0,0 +1,490 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021-2022 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 (guix read-print)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (pretty-print-with-comments
+            read-with-comments
+            object->string*
+
+            comment?
+            comment->string
+            comment-margin?
+            canonicalize-comment))
+
+;;; Commentary:
+;;;
+;;; This module provides a comment-preserving reader and a comment-preserving
+;;; pretty-printer smarter than (ice-9 pretty-print).
+;;;
+;;; Code:
+
+\f
+;;;
+;;; 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 layer on top of 'read',
+  ;; such that we don't have to rely on a specific Guile version.
+  (define dot (list 'dot))
+  (define (dot? x) (eq? x dot))
+
+  (define (reverse/dot lst)
+    ;; Reverse LST and make it an improper list if it contains DOT.
+    (let loop ((result '())
+               (lst lst))
+      (match lst
+        (() result)
+        (((? dot?) . rest)
+         (let ((dotted (reverse rest)))
+           (set-cdr! (last-pair dotted) (car result))
+           dotted))
+        ((x . rest) (loop (cons x result) rest)))))
+
+  (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/dot 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)
+              (match (read port)
+                ((and token '#{.}#)
+                 (if (eq? chr #\.) dot token))
+                (token token))))))))
+\f
+;;;
+;;; Comment-preserving pretty-printer.
+;;;
+
+(define-syntax vhashq
+  (syntax-rules (quote)
+    ((_) vlist-null)
+    ((_ (key (quote (lst ...))) rest ...)
+     (vhash-consq key '(lst ...) (vhashq rest ...)))
+    ((_ (key value) rest ...)
+     (vhash-consq key '((() . value)) (vhashq rest ...)))))
+
+(define %special-forms
+  ;; Forms that are indented specially.  The number is meant to be understood
+  ;; like Emacs' 'scheme-indent-function' symbol property.  When given an
+  ;; alist instead of a number, the alist gives "context" in which the symbol
+  ;; is a special form; for instance, context (modify-phases) means that the
+  ;; symbol must appear within a (modify-phases ...) expression.
+  (vhashq
+   ('begin 1)
+   ('lambda 2)
+   ('lambda* 2)
+   ('match-lambda 1)
+   ('match-lambda* 2)
+   ('define 2)
+   ('define* 2)
+   ('define-public 2)
+   ('define*-public 2)
+   ('define-syntax 2)
+   ('define-syntax-rule 2)
+   ('define-module 2)
+   ('define-gexp-compiler 2)
+   ('let 2)
+   ('let* 2)
+   ('letrec 2)
+   ('letrec* 2)
+   ('match 2)
+   ('when 2)
+   ('unless 2)
+   ('package 1)
+   ('origin 1)
+   ('operating-system 1)
+   ('modify-inputs 2)
+   ('modify-phases 2)
+   ('add-after '(((modify-phases) . 3)))
+   ('add-before '(((modify-phases) . 3)))
+   ('replace '(((modify-phases) . 2)))         ;different from 'modify-inputs'
+   ('substitute* 2)
+   ('substitute-keyword-arguments 2)
+   ('call-with-input-file 2)
+   ('call-with-output-file 2)
+   ('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))
+   ('git-reference '(uri origin source))
+   ('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)
+             (lst lst))
+    (match candidate
+      (() #t)
+      ((head1 . rest1)
+       (match lst
+         (() #f)
+         ((head2 . rest2)
+          (and (equal? head1 head2)
+               (loop rest1 rest2))))))))
+
+(define (special-form-lead symbol context)
+  "If SYMBOL is a special form in the given CONTEXT, return its number of
+arguments; otherwise return #f.  CONTEXT is a stack of symbols lexically
+surrounding SYMBOL."
+  (match (vhash-assq symbol %special-forms)
+    (#f #f)
+    ((_ . alist)
+     (any (match-lambda
+            ((prefix . level)
+             (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."
+  (list->string
+   `(#\"
+     ,@(string-fold-right (lambda (chr lst)
+                            (match chr
+                              (#\" (cons* #\\ #\" lst))
+                              (#\\ (cons* #\\ #\\ lst))
+                              (_   (cons chr lst))))
+                          '()
+                          str)
+     #\")))
+
+(define (string-width str)
+  "Return the \"width\" of STR--i.e., the width of the longest line of STR."
+  (apply max (map string-length (string-split str #\newline))))
+
+(define (canonicalize-comment c)
+  "Canonicalize comment C, ensuring it has the \"right\" number of leading
+semicolons."
+  (let ((line (string-trim-both
+               (string-trim (comment->string c) (char-set #\;)))))
+    (comment (string-append
+              (if (comment-margin? c)
+                  ";"
+                  (if (string-null? line)
+                      ";;"                        ;no trailing space
+                      ";; "))
+              line "\n")
+             (comment-margin? c))))
+
+(define* (pretty-print-with-comments port obj
+                                     #:key
+                                     (format-comment identity)
+                                     (indent 0)
+                                     (max-width 78)
+                                     (long-list 5))
+  "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns
+and assuming the current column is INDENT.  Comments present in OBJ are
+included in the output.
+
+Lists longer than LONG-LIST are written as one element per line.  Comments are
+passed through FORMAT-COMMENT before being emitted; a useful value for
+FORMAT-COMMENT is 'canonicalize-comment'."
+  (define (list-of-lists? head tail)
+    ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
+    ;; 'let' bindings.
+    (match head
+      ((thing _ ...)                              ;proper list
+       (and (not (memq thing
+                       '(quote quasiquote unquote unquote-splicing)))
+            (pair? tail)))
+      (_ #f)))
+
+  (let loop ((indent indent)
+             (column indent)
+             (delimited? #t)                  ;true if comes after a delimiter
+             (context '())                    ;list of "parent" symbols
+             (obj obj))
+    (define (print-sequence context indent column lst delimited?)
+      (define long?
+        (> (length lst) long-list))
+
+      (let print ((lst lst)
+                  (first? #t)
+                  (delimited? delimited?)
+                  (column column))
+        (match lst
+          (()
+           column)
+          ((item . tail)
+           (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.  Also insert a newline
+             ;; before a keyword.
+             (and (or (pair? item) long?
+                      (and (keyword? item)
+                           (not (eq? item #:allow-other-keys))))
+                  (not first?) (not delimited?)
+                  (not (comment? item))))
+
+           (when newline?
+             (newline port)
+             (display (make-string indent #\space) port))
+           (let ((column (if newline? indent column)))
+             (print tail
+                    (keyword? item)      ;keep #:key value next to one another
+                    (comment? item)
+                    (loop indent column
+                          (or newline? delimited?)
+                          context
+                          item)))))))
+
+    (define (sequence-would-protrude? indent lst)
+      ;; Return true if elements of LST written at INDENT would protrude
+      ;; beyond MAX-WIDTH.  This is implemented as a cheap test with false
+      ;; negatives to avoid actually rendering all of LST.
+      (find (match-lambda
+              ((? string? str)
+               (>= (+ (string-width str) 2 indent) max-width))
+              ((? symbol? symbol)
+               (>= (+ (string-width (symbol->string symbol)) indent)
+                   max-width))
+              ((? boolean?)
+               (>= (+ 2 indent) max-width))
+              (()
+               (>= (+ 2 indent) max-width))
+              (_                                  ;don't know
+               #f))
+            lst))
+
+    (define (special-form? head)
+      (special-form-lead head context))
+
+    (match obj
+      ((? comment? comment)
+       (if (comment-margin? comment)
+           (begin
+             (display " " port)
+             (display (comment->string (format-comment 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 (format-comment 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 context lst))
+      (('quasiquote lst)
+       (unless delimited? (display " " port))
+       (display "`" port)
+       (loop indent (+ column (if delimited? 1 2)) #t context lst))
+      (('unquote lst)
+       (unless delimited? (display " " port))
+       (display "," port)
+       (loop indent (+ column (if delimited? 1 2)) #t context lst))
+      (('unquote-splicing lst)
+       (unless delimited? (display " " port))
+       (display ",@" port)
+       (loop indent (+ column (if delimited? 2 3)) #t context lst))
+      (('gexp lst)
+       (unless delimited? (display " " port))
+       (display "#~" port)
+       (loop indent (+ column (if delimited? 2 3)) #t context lst))
+      (('ungexp obj)
+       (unless delimited? (display " " port))
+       (display "#$" port)
+       (loop indent (+ column (if delimited? 2 3)) #t context obj))
+      (('ungexp-native obj)
+       (unless delimited? (display " " port))
+       (display "#+" port)
+       (loop indent (+ column (if delimited? 2 3)) #t context obj))
+      (('ungexp-splicing lst)
+       (unless delimited? (display " " port))
+       (display "#$@" port)
+       (loop indent (+ column (if delimited? 3 4)) #t context lst))
+      (('ungexp-native-splicing lst)
+       (unless delimited? (display " " port))
+       (display "#+@" port)
+       (loop indent (+ column (if delimited? 3 4)) #t context lst))
+      (((? special-form? head) arguments ...)
+       ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
+       ;; and following arguments are less indented.
+       (let* ((lead    (special-form-lead head context))
+              (context (cons head context))
+              (head    (symbol->string head))
+              (total   (length arguments)))
+         (unless delimited? (display " " port))
+         (display "(" port)
+         (display head port)
+         (unless (zero? lead)
+           (display " " port))
+
+         ;; Print the first LEAD arguments.
+         (let* ((indent (+ column 2
+                                  (if delimited? 0 1)))
+                (column (+ column 1
+                                  (if (zero? lead) 0 1)
+                                  (if delimited? 0 1)
+                                  (string-length head)))
+                (initial-indent column))
+           (define new-column
+             (let inner ((n lead)
+                         (arguments (take arguments (min lead total)))
+                         (column column))
+               (if (zero? n)
+                   (begin
+                     (newline port)
+                     (display (make-string indent #\space) port)
+                     indent)
+                   (match arguments
+                     (() column)
+                     ((head . tail)
+                      (inner (- n 1) tail
+                             (loop initial-indent column
+                                   (= n lead)
+                                   context
+                                   head)))))))
+
+           ;; Print the remaining arguments.
+           (let ((column (print-sequence
+                          context indent new-column
+                          (drop arguments (min lead total))
+                          #t)))
+             (display ")" port)
+             (+ column 1)))))
+      ((head tail ...)
+       (let* ((overflow? (>= column max-width))
+              (column    (if overflow?
+                             (+ indent 1)
+                             (+ column (if delimited? 1 2))))
+              (newline?  (or (newline-form? head context)
+                             (list-of-lists? head tail))) ;'let' bindings
+              (context   (cons head context)))
+         (if overflow?
+             (begin
+               (newline port)
+               (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)
+                                newline?)
+                            column
+                            (+ new-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)
+                       (object->string obj)))
+              (len (string-width str)))
+         (if (and (> (+ column 1 len) max-width)
+                  (not delimited?))
+             (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? 0 1) len))))))))
+
+(define (object->string* obj indent . args)
+  "Pretty-print OBJ with INDENT columns as the initial indent.  ARGS are
+passed as-is to 'pretty-print-with-comments'."
+  (call-with-output-string
+    (lambda (port)
+      (apply pretty-print-with-comments port obj
+             #:indent indent
+             args))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 71ab4b4fed..bd3cfd2dc3 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
@@ -25,7 +25,7 @@
 (define-module (guix scripts import)
   #:use-module (guix ui)
   #:use-module (guix scripts)
-  #:use-module (guix scripts style)
+  #:use-module (guix read-print)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 9fd652beb1..e2530e80c0 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -37,468 +37,15 @@ (define-module (guix scripts style)
   #:use-module (guix utils)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
+  #:use-module (guix read-print)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 vlist)
   #: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 (pretty-print-with-comments
-            read-with-comments
-            canonicalize-comment
-
-            guix-style))
-
-\f
-;;;
-;;; 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 layer on top of 'read',
-  ;; such that we don't have to rely on a specific Guile version.
-  (define dot (list 'dot))
-  (define (dot? x) (eq? x dot))
-
-  (define (reverse/dot lst)
-    ;; Reverse LST and make it an improper list if it contains DOT.
-    (let loop ((result '())
-               (lst lst))
-      (match lst
-        (() result)
-        (((? dot?) . rest)
-         (let ((dotted (reverse rest)))
-           (set-cdr! (last-pair dotted) (car result))
-           dotted))
-        ((x . rest) (loop (cons x result) rest)))))
-
-  (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/dot 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)
-              (match (read port)
-                ((and token '#{.}#)
-                 (if (eq? chr #\.) dot token))
-                (token token))))))))
-\f
-;;;
-;;; Comment-preserving pretty-printer.
-;;;
-
-(define-syntax vhashq
-  (syntax-rules (quote)
-    ((_) vlist-null)
-    ((_ (key (quote (lst ...))) rest ...)
-     (vhash-consq key '(lst ...) (vhashq rest ...)))
-    ((_ (key value) rest ...)
-     (vhash-consq key '((() . value)) (vhashq rest ...)))))
-
-(define %special-forms
-  ;; Forms that are indented specially.  The number is meant to be understood
-  ;; like Emacs' 'scheme-indent-function' symbol property.  When given an
-  ;; alist instead of a number, the alist gives "context" in which the symbol
-  ;; is a special form; for instance, context (modify-phases) means that the
-  ;; symbol must appear within a (modify-phases ...) expression.
-  (vhashq
-   ('begin 1)
-   ('lambda 2)
-   ('lambda* 2)
-   ('match-lambda 1)
-   ('match-lambda* 2)
-   ('define 2)
-   ('define* 2)
-   ('define-public 2)
-   ('define*-public 2)
-   ('define-syntax 2)
-   ('define-syntax-rule 2)
-   ('define-module 2)
-   ('define-gexp-compiler 2)
-   ('let 2)
-   ('let* 2)
-   ('letrec 2)
-   ('letrec* 2)
-   ('match 2)
-   ('when 2)
-   ('unless 2)
-   ('package 1)
-   ('origin 1)
-   ('operating-system 1)
-   ('modify-inputs 2)
-   ('modify-phases 2)
-   ('add-after '(((modify-phases) . 3)))
-   ('add-before '(((modify-phases) . 3)))
-   ('replace '(((modify-phases) . 2)))         ;different from 'modify-inputs'
-   ('substitute* 2)
-   ('substitute-keyword-arguments 2)
-   ('call-with-input-file 2)
-   ('call-with-output-file 2)
-   ('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))
-   ('git-reference '(uri origin source))
-   ('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)
-             (lst lst))
-    (match candidate
-      (() #t)
-      ((head1 . rest1)
-       (match lst
-         (() #f)
-         ((head2 . rest2)
-          (and (equal? head1 head2)
-               (loop rest1 rest2))))))))
-
-(define (special-form-lead symbol context)
-  "If SYMBOL is a special form in the given CONTEXT, return its number of
-arguments; otherwise return #f.  CONTEXT is a stack of symbols lexically
-surrounding SYMBOL."
-  (match (vhash-assq symbol %special-forms)
-    (#f #f)
-    ((_ . alist)
-     (any (match-lambda
-            ((prefix . level)
-             (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."
-  (list->string
-   `(#\"
-     ,@(string-fold-right (lambda (chr lst)
-                            (match chr
-                              (#\" (cons* #\\ #\" lst))
-                              (#\\ (cons* #\\ #\\ lst))
-                              (_   (cons chr lst))))
-                          '()
-                          str)
-     #\")))
-
-(define (string-width str)
-  "Return the \"width\" of STR--i.e., the width of the longest line of STR."
-  (apply max (map string-length (string-split str #\newline))))
-
-(define (canonicalize-comment c)
-  "Canonicalize comment C, ensuring it has the \"right\" number of leading
-semicolons."
-  (let ((line (string-trim-both
-               (string-trim (comment->string c) (char-set #\;)))))
-    (comment (string-append
-              (if (comment-margin? c)
-                  ";"
-                  (if (string-null? line)
-                      ";;"                        ;no trailing space
-                      ";; "))
-              line "\n")
-             (comment-margin? c))))
-
-(define* (pretty-print-with-comments port obj
-                                     #:key
-                                     (format-comment identity)
-                                     (indent 0)
-                                     (max-width 78)
-                                     (long-list 5))
-  "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns
-and assuming the current column is INDENT.  Comments present in OBJ are
-included in the output.
-
-Lists longer than LONG-LIST are written as one element per line.  Comments are
-passed through FORMAT-COMMENT before being emitted; a useful value for
-FORMAT-COMMENT is 'canonicalize-comment'."
-  (define (list-of-lists? head tail)
-    ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
-    ;; 'let' bindings.
-    (match head
-      ((thing _ ...)                              ;proper list
-       (and (not (memq thing
-                       '(quote quasiquote unquote unquote-splicing)))
-            (pair? tail)))
-      (_ #f)))
-
-  (let loop ((indent indent)
-             (column indent)
-             (delimited? #t)                  ;true if comes after a delimiter
-             (context '())                    ;list of "parent" symbols
-             (obj obj))
-    (define (print-sequence context indent column lst delimited?)
-      (define long?
-        (> (length lst) long-list))
-
-      (let print ((lst lst)
-                  (first? #t)
-                  (delimited? delimited?)
-                  (column column))
-        (match lst
-          (()
-           column)
-          ((item . tail)
-           (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.  Also insert a newline
-             ;; before a keyword.
-             (and (or (pair? item) long?
-                      (and (keyword? item)
-                           (not (eq? item #:allow-other-keys))))
-                  (not first?) (not delimited?)
-                  (not (comment? item))))
-
-           (when newline?
-             (newline port)
-             (display (make-string indent #\space) port))
-           (let ((column (if newline? indent column)))
-             (print tail
-                    (keyword? item)      ;keep #:key value next to one another
-                    (comment? item)
-                    (loop indent column
-                          (or newline? delimited?)
-                          context
-                          item)))))))
-
-    (define (sequence-would-protrude? indent lst)
-      ;; Return true if elements of LST written at INDENT would protrude
-      ;; beyond MAX-WIDTH.  This is implemented as a cheap test with false
-      ;; negatives to avoid actually rendering all of LST.
-      (find (match-lambda
-              ((? string? str)
-               (>= (+ (string-width str) 2 indent) max-width))
-              ((? symbol? symbol)
-               (>= (+ (string-width (symbol->string symbol)) indent)
-                   max-width))
-              ((? boolean?)
-               (>= (+ 2 indent) max-width))
-              (()
-               (>= (+ 2 indent) max-width))
-              (_                                  ;don't know
-               #f))
-            lst))
-
-    (define (special-form? head)
-      (special-form-lead head context))
-
-    (match obj
-      ((? comment? comment)
-       (if (comment-margin? comment)
-           (begin
-             (display " " port)
-             (display (comment->string (format-comment 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 (format-comment 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 context lst))
-      (('quasiquote lst)
-       (unless delimited? (display " " port))
-       (display "`" port)
-       (loop indent (+ column (if delimited? 1 2)) #t context lst))
-      (('unquote lst)
-       (unless delimited? (display " " port))
-       (display "," port)
-       (loop indent (+ column (if delimited? 1 2)) #t context lst))
-      (('unquote-splicing lst)
-       (unless delimited? (display " " port))
-       (display ",@" port)
-       (loop indent (+ column (if delimited? 2 3)) #t context lst))
-      (('gexp lst)
-       (unless delimited? (display " " port))
-       (display "#~" port)
-       (loop indent (+ column (if delimited? 2 3)) #t context lst))
-      (('ungexp obj)
-       (unless delimited? (display " " port))
-       (display "#$" port)
-       (loop indent (+ column (if delimited? 2 3)) #t context obj))
-      (('ungexp-native obj)
-       (unless delimited? (display " " port))
-       (display "#+" port)
-       (loop indent (+ column (if delimited? 2 3)) #t context obj))
-      (('ungexp-splicing lst)
-       (unless delimited? (display " " port))
-       (display "#$@" port)
-       (loop indent (+ column (if delimited? 3 4)) #t context lst))
-      (('ungexp-native-splicing lst)
-       (unless delimited? (display " " port))
-       (display "#+@" port)
-       (loop indent (+ column (if delimited? 3 4)) #t context lst))
-      (((? special-form? head) arguments ...)
-       ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
-       ;; and following arguments are less indented.
-       (let* ((lead    (special-form-lead head context))
-              (context (cons head context))
-              (head    (symbol->string head))
-              (total   (length arguments)))
-         (unless delimited? (display " " port))
-         (display "(" port)
-         (display head port)
-         (unless (zero? lead)
-           (display " " port))
-
-         ;; Print the first LEAD arguments.
-         (let* ((indent (+ column 2
-                                  (if delimited? 0 1)))
-                (column (+ column 1
-                                  (if (zero? lead) 0 1)
-                                  (if delimited? 0 1)
-                                  (string-length head)))
-                (initial-indent column))
-           (define new-column
-             (let inner ((n lead)
-                         (arguments (take arguments (min lead total)))
-                         (column column))
-               (if (zero? n)
-                   (begin
-                     (newline port)
-                     (display (make-string indent #\space) port)
-                     indent)
-                   (match arguments
-                     (() column)
-                     ((head . tail)
-                      (inner (- n 1) tail
-                             (loop initial-indent column
-                                   (= n lead)
-                                   context
-                                   head)))))))
-
-           ;; Print the remaining arguments.
-           (let ((column (print-sequence
-                          context indent new-column
-                          (drop arguments (min lead total))
-                          #t)))
-             (display ")" port)
-             (+ column 1)))))
-      ((head tail ...)
-       (let* ((overflow? (>= column max-width))
-              (column    (if overflow?
-                             (+ indent 1)
-                             (+ column (if delimited? 1 2))))
-              (newline?  (or (newline-form? head context)
-                             (list-of-lists? head tail))) ;'let' bindings
-              (context   (cons head context)))
-         (if overflow?
-             (begin
-               (newline port)
-               (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)
-                                newline?)
-                            column
-                            (+ new-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)
-                       (object->string obj)))
-              (len (string-width str)))
-         (if (and (> (+ column 1 len) max-width)
-                  (not delimited?))
-             (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? 0 1) len))))))))
-
-(define (object->string* obj indent . args)
-  (call-with-output-string
-    (lambda (port)
-      (apply pretty-print-with-comments port obj
-             #:indent indent
-             args))))
+  #:export (guix-style))
 
 \f
 ;;;
diff --git a/tests/read-print.scm b/tests/read-print.scm
new file mode 100644
index 0000000000..e9ba1127d4
--- /dev/null
+++ b/tests/read-print.scm
@@ -0,0 +1,209 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021-2022 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 read-print)
+  #:use-module (guix gexp)                        ;for the reader extensions
+  #:use-module (srfi srfi-64))
+
+(define-syntax-rule (test-pretty-print str args ...)
+  "Test equality after a round-trip where STR is passed to
+'read-with-comments' and the resulting sexp is then passed to
+'pretty-print-with-comments'."
+  (test-equal str
+    (call-with-output-string
+      (lambda (port)
+        (let ((exp (call-with-input-string str
+                     read-with-comments)))
+         (pretty-print-with-comments port exp args ...))))))
+
+\f
+(test-begin "read-print")
+
+(test-equal "read-with-comments: dot notation"
+  (cons 'a 'b)
+  (call-with-input-string "(a . b)"
+    read-with-comments))
+
+(test-pretty-print "(list 1 2 3 4)")
+(test-pretty-print "((a . 1) (b . 2))")
+(test-pretty-print "(a b c . boom)")
+(test-pretty-print "(list 1
+                          2
+                          3
+                          4)"
+                   #:long-list 3
+                   #:indent 20)
+(test-pretty-print "\
+(list abc
+      def)"
+                   #:max-width 11)
+(test-pretty-print "\
+(#:foo
+ #:bar)"
+                   #:max-width 10)
+
+(test-pretty-print "\
+(#:first 1
+ #:second 2
+ #:third 3)")
+
+(test-pretty-print "\
+((x
+  1)
+ (y
+  2)
+ (z
+  3))"
+                   #:max-width 3)
+
+(test-pretty-print "\
+(let ((x 1)
+      (y 2)
+      (z 3)
+      (p 4))
+  (+ x y))"
+                   #:max-width 11)
+
+(test-pretty-print "\
+(lambda (x y)
+  ;; This is a procedure.
+  (let ((z (+ x y)))
+    (* z z)))")
+
+(test-pretty-print "\
+#~(string-append #$coreutils \"/bin/uname\")")
+
+(test-pretty-print "\
+(package
+  (inherit coreutils)
+  (version \"42\"))")
+
+(test-pretty-print "\
+(modify-phases %standard-phases
+  (add-after 'unpack 'post-unpack
+    (lambda _
+      #t))
+  (add-before 'check 'pre-check
+    (lambda* (#:key inputs #:allow-other-keys)
+      do things ...)))")
+
+(test-pretty-print "\
+(#:phases (modify-phases sdfsdf
+            (add-before 'x 'y
+              (lambda _
+                xyz))))")
+
+(test-pretty-print "\
+(description \"abcdefghijkl
+mnopqrstuvwxyz.\")"
+                   #:max-width 30)
+
+(test-pretty-print "\
+(description
+ \"abcdefghijkl
+mnopqrstuvwxyz.\")"
+                   #:max-width 12)
+
+(test-pretty-print "\
+(description
+ \"abcdefghijklmnopqrstuvwxyz\")"
+                   #:max-width 33)
+
+(test-pretty-print "\
+(modify-phases %standard-phases
+  (replace 'build
+    ;; Nicely indented in 'modify-phases' context.
+    (lambda _
+      #t)))")
+
+(test-pretty-print "\
+(modify-inputs inputs
+  ;; 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)))")
+
+;; '#:key value' is kept on the same line.
+(test-pretty-print "\
+(package
+  (name \"keyword-value-same-line\")
+  (arguments
+   (list #:phases #~(modify-phases %standard-phases
+                      (add-before 'x 'y
+                        (lambda* (#:key inputs #:allow-other-keys)
+                          (foo bar baz))))
+         #:make-flags #~'(\"ANSWER=42\")
+         #:tests? #f)))")
+
+(test-pretty-print "\
+(let ((x 1)
+      (y 2)
+      (z (let* ((a 3)
+                (b 4))
+           (+ a b))))
+  (list x y z))")
+
+(test-pretty-print "\
+(substitute-keyword-arguments (package-arguments x)
+  ((#:phases phases)
+   `(modify-phases ,phases
+      (add-before 'build 'do-things
+        (lambda _
+          #t))))
+  ((#:configure-flags flags)
+   `(cons \"--without-any-problem\"
+          ,flags)))")
+
+(test-equal "pretty-print-with-comments, canonicalize-comment"
+  "\
+(list abc
+      ;; Not a margin comment.
+      ;; Ditto.
+      ;;
+      ;; There's a blank line above.
+      def ;margin comment
+      ghi)"
+  (let ((sexp (call-with-input-string
+                  "\
+(list abc
+  ;Not a margin comment.
+  ;;;  Ditto.
+  ;;;;;
+  ; There's a blank line above.
+  def  ;; margin comment
+  ghi)"
+                read-with-comments)))
+    (call-with-output-string
+      (lambda (port)
+        (pretty-print-with-comments port sexp
+                                    #:format-comment
+                                    canonicalize-comment)))))
+
+(test-end)
diff --git a/tests/style.scm b/tests/style.scm
index 55bad2b3ba..4ac5ae7c09 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -113,17 +113,6 @@ (define* (read-package-field package field #:optional (count 1))
       (lambda (port)
         (read-lines port line count)))))
 
-(define-syntax-rule (test-pretty-print str args ...)
-  "Test equality after a round-trip where STR is passed to
-'read-with-comments' and the resulting sexp is then passed to
-'pretty-print-with-comments'."
-  (test-equal str
-    (call-with-output-string
-      (lambda (port)
-        (let ((exp (call-with-input-string str
-                     read-with-comments)))
-         (pretty-print-with-comments port exp args ...))))))
-
 \f
 (test-begin "style")
 
@@ -377,176 +366,6 @@ (define file
       (list (package-inputs (@ (my-packages) my-coreutils))
             (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
 
-(test-equal "read-with-comments: dot notation"
-  (cons 'a 'b)
-  (call-with-input-string "(a . b)"
-    read-with-comments))
-
-(test-pretty-print "(list 1 2 3 4)")
-(test-pretty-print "((a . 1) (b . 2))")
-(test-pretty-print "(a b c . boom)")
-(test-pretty-print "(list 1
-                          2
-                          3
-                          4)"
-                   #:long-list 3
-                   #:indent 20)
-(test-pretty-print "\
-(list abc
-      def)"
-                   #:max-width 11)
-(test-pretty-print "\
-(#:foo
- #:bar)"
-                   #:max-width 10)
-
-(test-pretty-print "\
-(#:first 1
- #:second 2
- #:third 3)")
-
-(test-pretty-print "\
-((x
-  1)
- (y
-  2)
- (z
-  3))"
-                   #:max-width 3)
-
-(test-pretty-print "\
-(let ((x 1)
-      (y 2)
-      (z 3)
-      (p 4))
-  (+ x y))"
-                   #:max-width 11)
-
-(test-pretty-print "\
-(lambda (x y)
-  ;; This is a procedure.
-  (let ((z (+ x y)))
-    (* z z)))")
-
-(test-pretty-print "\
-#~(string-append #$coreutils \"/bin/uname\")")
-
-(test-pretty-print "\
-(package
-  (inherit coreutils)
-  (version \"42\"))")
-
-(test-pretty-print "\
-(modify-phases %standard-phases
-  (add-after 'unpack 'post-unpack
-    (lambda _
-      #t))
-  (add-before 'check 'pre-check
-    (lambda* (#:key inputs #:allow-other-keys)
-      do things ...)))")
-
-(test-pretty-print "\
-(#:phases (modify-phases sdfsdf
-            (add-before 'x 'y
-              (lambda _
-                xyz))))")
-
-(test-pretty-print "\
-(description \"abcdefghijkl
-mnopqrstuvwxyz.\")"
-                   #:max-width 30)
-
-(test-pretty-print "\
-(description
- \"abcdefghijkl
-mnopqrstuvwxyz.\")"
-                   #:max-width 12)
-
-(test-pretty-print "\
-(description
- \"abcdefghijklmnopqrstuvwxyz\")"
-                   #:max-width 33)
-
-(test-pretty-print "\
-(modify-phases %standard-phases
-  (replace 'build
-    ;; Nicely indented in 'modify-phases' context.
-    (lambda _
-      #t)))")
-
-(test-pretty-print "\
-(modify-inputs inputs
-  ;; 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)))")
-
-;; '#:key value' is kept on the same line.
-(test-pretty-print "\
-(package
-  (name \"keyword-value-same-line\")
-  (arguments
-   (list #:phases #~(modify-phases %standard-phases
-                      (add-before 'x 'y
-                        (lambda* (#:key inputs #:allow-other-keys)
-                          (foo bar baz))))
-         #:make-flags #~'(\"ANSWER=42\")
-         #:tests? #f)))")
-
-(test-pretty-print "\
-(let ((x 1)
-      (y 2)
-      (z (let* ((a 3)
-                (b 4))
-           (+ a b))))
-  (list x y z))")
-
-(test-pretty-print "\
-(substitute-keyword-arguments (package-arguments x)
-  ((#:phases phases)
-   `(modify-phases ,phases
-      (add-before 'build 'do-things
-        (lambda _
-          #t))))
-  ((#:configure-flags flags)
-   `(cons \"--without-any-problem\"
-          ,flags)))")
-
-(test-equal "pretty-print-with-comments, canonicalize-comment"
-  "\
-(list abc
-      ;; Not a margin comment.
-      ;; Ditto.
-      ;;
-      ;; There's a blank line above.
-      def ;margin comment
-      ghi)"
-  (let ((sexp (call-with-input-string
-                  "\
-(list abc
-  ;Not a margin comment.
-  ;;;  Ditto.
-  ;;;;;
-  ; There's a blank line above.
-  def  ;; margin comment
-  ghi)"
-                read-with-comments)))
-    (call-with-output-string
-      (lambda (port)
-        (pretty-print-with-comments port sexp
-                                    #:format-comment
-                                    canonicalize-comment)))))
 
 (test-end)
 
-- 
2.37.1

[bug#56898] [PATCH 02/13] read-print: Add System and Home special forms.

[Ludovic Courtès]

* guix/read-print.scm (%special-forms): Add System and Home forms.
(%newline-forms): Add 'services'.
---
 guix/read-print.scm | 24 +++++++++++++++++++++---
 1 file changed, 21 insertions(+), 3 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 69ab8ac8b3..949a713ca2 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -156,7 +156,6 @@ (define %special-forms
    ('unless 2)
    ('package 1)
    ('origin 1)
-   ('operating-system 1)
    ('modify-inputs 2)
    ('modify-phases 2)
    ('add-after '(((modify-phases) . 3)))
@@ -167,7 +166,22 @@ (define %special-forms
    ('call-with-input-file 2)
    ('call-with-output-file 2)
    ('with-output-to-file 2)
-   ('with-input-from-file 2)))
+   ('with-input-from-file 2)
+   ('with-directory-excursion 2)
+
+   ;; (gnu system) and (gnu services).
+   ('operating-system 1)
+   ('bootloader-configuration 1)
+   ('mapped-device 1)
+   ('file-system 1)
+   ('swap-space 1)
+   ('user-account 1)
+   ('user-group 1)
+   ('setuid-program 1)
+   ('modify-services 2)
+
+   ;; (gnu home).
+   ('home-environment 1)))
 
 (define %newline-forms
   ;; List heads that must be followed by a newline.  The second argument is
@@ -180,7 +194,11 @@ (define %newline-forms
    ('git-reference '(uri origin source))
    ('search-paths '(package))
    ('native-search-paths '(package))
-   ('search-path-specification '())))
+   ('search-path-specification '())
+
+   ('services '(operating-system))
+   ('set-xorg-configuration '())
+   ('services '(home-environment))))
 
 (define (prefix? candidate lst)
   "Return true if CANDIDATE is a prefix of LST."
-- 
2.37.1

[bug#56898] [PATCH 03/13] read-print: Expose comment constructor.

[Ludovic Courtès]

* guix/read-print.scm (<comment>): Rename constructor to
'string->comment'.
(comment): New procedure.
(read-with-comments, canonicalize-comment): Use 'string->comment'
instead of 'comment'.
---
 guix/read-print.scm | 36 +++++++++++++++++++++++++-----------
 1 file changed, 25 insertions(+), 11 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 949a713ca2..5281878504 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -23,10 +23,13 @@ (define-module (guix read-print)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:export (pretty-print-with-comments
             read-with-comments
             object->string*
 
+            comment
             comment?
             comment->string
             comment-margin?
@@ -46,11 +49,22 @@ (define-module (guix read-print)
 
 ;; A comment.
 (define-record-type <comment>
-  (comment str margin?)
+  (string->comment str margin?)
   comment?
   (str     comment->string)
   (margin? comment-margin?))
 
+(define* (comment str #:optional margin?)
+  "Return a new comment made from STR.  When MARGIN? is true, return a margin
+comment; otherwise return a line comment.  STR must start with a semicolon and
+end with newline, otherwise an error is raised."
+  (when (or (string-null? str)
+            (not (eqv? #\; (string-ref str 0)))
+            (not (string-suffix? "\n" str)))
+    (raise (condition
+            (&message (message "invalid comment string")))))
+  (string->comment str 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
@@ -106,8 +120,8 @@ (define (reverse/dot lst)
                     (loop #f return)))
              ((eqv? chr #\;)
               (unread-char chr port)
-              (comment (read-line port 'concat)
-                       (not blank-line?)))
+              (string->comment (read-line port 'concat)
+                               (not blank-line?)))
              (else
               (unread-char chr port)
               (match (read port)
@@ -256,14 +270,14 @@ (define (canonicalize-comment c)
 semicolons."
   (let ((line (string-trim-both
                (string-trim (comment->string c) (char-set #\;)))))
-    (comment (string-append
-              (if (comment-margin? c)
-                  ";"
-                  (if (string-null? line)
-                      ";;"                        ;no trailing space
-                      ";; "))
-              line "\n")
-             (comment-margin? c))))
+    (string->comment (string-append
+                      (if (comment-margin? c)
+                          ";"
+                          (if (string-null? line)
+                              ";;"                        ;no trailing space
+                              ";; "))
+                      line "\n")
+                     (comment-margin? c))))
 
 (define* (pretty-print-with-comments port obj
                                      #:key
-- 
2.37.1

[bug#56898] [PATCH 04/13] read-print: Introduce <blank> parent class of <comment>.

[Ludovic Courtès]

* guix/read-print.scm (<blank>, blank?): New record type.
(<comment>): Redefine using the record interface.
(read-with-comments, pretty-print-with-comments): Change some uses of
'comment?' to 'blank?'.
* guix/scripts/style.scm (simplify-inputs)[simplify-expressions]: Use
'blank?' instead of 'comment?'.
---
 guix/read-print.scm    | 37 ++++++++++++++++++++++++++-----------
 guix/scripts/style.scm |  2 +-
 2 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 5281878504..732d0dc1f8 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -22,13 +22,14 @@ (define-module (guix read-print)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (pretty-print-with-comments
             read-with-comments
             object->string*
 
+            blank?
+
             comment
             comment?
             comment->string
@@ -47,12 +48,26 @@ (define-module (guix read-print)
 ;;; Comment-preserving reader.
 ;;;
 
-;; A comment.
-(define-record-type <comment>
-  (string->comment str margin?)
-  comment?
-  (str     comment->string)
-  (margin? comment-margin?))
+(define <blank>
+  ;; The parent class for "blanks".
+  (make-record-type '<blank> '()
+                    (lambda (obj port)
+                      (format port "#<blank ~a>"
+                              (number->string (object-address obj) 16)))
+                    #:extensible? #t))
+
+(define blank? (record-predicate <blank>))
+
+(define <comment>
+  ;; Comments.
+  (make-record-type '<comment> '(str margin?)
+                    #:parent <blank>
+                    #:extensible? #f))
+
+(define comment?        (record-predicate <comment>))
+(define string->comment (record-type-constructor <comment>))
+(define comment->string (record-accessor <comment> 'str))
+(define comment-margin? (record-accessor <comment> 'margin?))
 
 (define* (comment str #:optional margin?)
   "Return a new comment made from STR.  When MARGIN? is true, return a margin
@@ -66,7 +81,7 @@ (define* (comment str #:optional margin?)
   (string->comment str margin?))
 
 (define (read-with-comments port)
-  "Like 'read', but include <comment> objects when they're encountered."
+  "Like 'read', but include <blank> 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 layer on top of 'read',
   ;; such that we don't have to rely on a specific Guile version.
@@ -99,7 +114,7 @@ (define (reverse/dot lst)
               (let/ec return
                 (let liip ((lst '()))
                   (liip (cons (loop (match lst
-                                      (((? comment?) . _) #t)
+                                      (((? blank?) . _) #t)
                                       (_ #f))
                                     (lambda ()
                                       (return (reverse/dot lst))))
@@ -327,7 +342,7 @@ (define newline?
                       (and (keyword? item)
                            (not (eq? item #:allow-other-keys))))
                   (not first?) (not delimited?)
-                  (not (comment? item))))
+                  (not (blank? item))))
 
            (when newline?
              (newline port)
@@ -335,7 +350,7 @@ (define newline?
            (let ((column (if newline? indent column)))
              (print tail
                     (keyword? item)      ;keep #:key value next to one another
-                    (comment? item)
+                    (blank? item)
                     (loop indent column
                           (or newline? delimited?)
                           context
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index e2530e80c0..5c0ecc0896 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -108,7 +108,7 @@ (define (simplify-expressions exp inputs return)
                (exp exp)
                (inputs inputs))
       (match exp
-        (((? comment? head) . rest)
+        (((? blank? head) . rest)
          (loop (cons head result) rest inputs))
         ((head . rest)
          (match inputs
-- 
2.37.1

[bug#56898] [PATCH 05/13] style: Adjust test to not emit blank lines.

[Ludovic Courtès]

Previously this test would produce a file containing blank lines between
inputs.

* tests/style.scm ("input labels, modify-inputs and margin comment"):
Remove trailing newlines in replacement strings of 'substitute*'
expression.
---
 tests/style.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tests/style.scm b/tests/style.scm
index 4ac5ae7c09..6aab2c3785 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -355,9 +355,9 @@ (define file
 
       (substitute* file
         ((",gmp\\)(.*)$" _ rest)
-         (string-append ",gmp) ;margin comment\n" rest))
+         (string-append ",gmp) ;margin comment" rest))
         ((",acl\\)(.*)$" _ rest)
-         (string-append ",acl) ;another one\n" rest)))
+         (string-append ",acl) ;another one" rest)))
 
       (system* "guix" "style" "-L" directory "-S" "inputs"
                "my-coreutils")
-- 
2.37.1

[bug#56898] [PATCH 06/13] read-print: Read and render vertical space.

[Ludovic Courtès]

* guix/read-print.scm (<vertical-space>, vertical-space?)
(vertical-space, vertical-space-height): New variables.
(combine-vertical-space, canonicalize-vertical-space)
(read-vertical-space): New procedures.
(read-with-comments): Use it in the #\newline case.
(pretty-print-with-comments): Add #:format-vertical-space and honor it.
Add case for 'vertical-space?'.
* guix/scripts/style.scm (format-package-definition): Pass
 #:format-vertical-space to 'object->string*'.
* tests/read-print.scm ("read-with-comments: list with blank line")
("read-with-comments: list with multiple blank lines")
("read-with-comments: top-level blank lines")
("pretty-print-with-comments, canonicalize-vertical-space"): New tests.
Add a couple of additional round-trip tests.
---
 guix/read-print.scm    | 54 ++++++++++++++++++++++++++++--
 guix/scripts/style.scm |  3 +-
 tests/read-print.scm   | 76 +++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 129 insertions(+), 4 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 732d0dc1f8..2b626ba281 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -30,6 +30,11 @@ (define-module (guix read-print)
 
             blank?
 
+            vertical-space
+            vertical-space?
+            vertical-space-height
+            canonicalize-vertical-space
+
             comment
             comment?
             comment->string
@@ -58,6 +63,26 @@ (define <blank>
 
 (define blank? (record-predicate <blank>))
 
+(define <vertical-space>
+  (make-record-type '<vertical-space> '(height)
+                    #:parent <blank>
+                    #:extensible? #f))
+
+(define vertical-space?       (record-predicate <vertical-space>))
+(define vertical-space        (record-type-constructor <vertical-space>))
+(define vertical-space-height (record-accessor <vertical-space> 'height))
+
+(define (combine-vertical-space x y)
+  "Return vertical space as high as the combination of X and Y."
+  (vertical-space (+ (vertical-space-height x)
+                     (vertical-space-height y))))
+
+(define canonicalize-vertical-space
+  (let ((unit (vertical-space 1)))
+    (lambda (space)
+      "Return a vertical space corresponding to a single blank line."
+      unit)))
+
 (define <comment>
   ;; Comments.
   (make-record-type '<comment> '(str margin?)
@@ -80,6 +105,19 @@ (define* (comment str #:optional margin?)
             (&message (message "invalid comment string")))))
   (string->comment str margin?))
 
+(define (read-vertical-space port)
+  "Read from PORT until a non-vertical-space character is met, and return a
+single <vertical-space> record."
+  (define (space? chr)
+    (char-set-contains? char-set:whitespace chr))
+
+  (let loop ((height 1))
+    (match (read-char port)
+      (#\newline (loop (+ 1 height)))
+      ((? eof-object?) (vertical-space height))
+      ((? space?) (loop height))
+      (chr (unread-char chr port) (vertical-space height)))))
+
 (define (read-with-comments port)
   "Like 'read', but include <blank> objects when they're encountered."
   ;; Note: Instead of implementing this functionality in 'read' proper, which
@@ -107,7 +145,9 @@ (define (reverse/dot lst)
        eof)                                       ;oops!
       (chr
        (cond ((eqv? chr #\newline)
-              (loop #t return))
+              (if blank-line?
+                  (read-vertical-space port)
+                  (loop #t return)))
              ((char-set-contains? char-set:whitespace chr)
               (loop blank-line? return))
              ((memv chr '(#\( #\[))
@@ -297,6 +337,7 @@ (define (canonicalize-comment c)
 (define* (pretty-print-with-comments port obj
                                      #:key
                                      (format-comment identity)
+                                     (format-vertical-space identity)
                                      (indent 0)
                                      (max-width 78)
                                      (long-list 5))
@@ -306,7 +347,8 @@ (define* (pretty-print-with-comments port obj
 
 Lists longer than LONG-LIST are written as one element per line.  Comments are
 passed through FORMAT-COMMENT before being emitted; a useful value for
-FORMAT-COMMENT is 'canonicalize-comment'."
+FORMAT-COMMENT is 'canonicalize-comment'.  Vertical space is passed through
+FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'."
   (define (list-of-lists? head tail)
     ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
     ;; 'let' bindings.
@@ -394,6 +436,14 @@ (define (special-form? head)
                       port)))
        (display (make-string indent #\space) port)
        indent)
+      ((? vertical-space? space)
+       (unless delimited? (newline port))
+       (let loop ((i (vertical-space-height (format-vertical-space space))))
+         (unless (zero? i)
+           (newline port)
+           (loop (- i 1))))
+       (display (make-string indent #\space) port)
+       indent)
       (('quote lst)
        (unless delimited? (display " " port))
        (display "'" port)
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 5c0ecc0896..2e14bc68fd 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -316,7 +316,8 @@ (define* (format-package-definition package
        (object->string* exp
                         (location-column
                          (package-definition-location package))
-                        #:format-comment canonicalize-comment)))))
+                        #:format-comment canonicalize-comment
+                        #:format-vertical-space canonicalize-vertical-space)))))
 
 (define (package-location<? p1 p2)
   "Return true if P1's location is \"before\" P2's."
diff --git a/tests/read-print.scm b/tests/read-print.scm
index e9ba1127d4..f915b7e2d2 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -19,7 +19,8 @@
 (define-module (tests-style)
   #:use-module (guix read-print)
   #:use-module (guix gexp)                        ;for the reader extensions
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match))
 
 (define-syntax-rule (test-pretty-print str args ...)
   "Test equality after a round-trip where STR is passed to
@@ -40,6 +41,35 @@ (define-syntax-rule (test-pretty-print str args ...)
   (call-with-input-string "(a . b)"
     read-with-comments))
 
+(test-equal "read-with-comments: list with blank line"
+  `(list with ,(vertical-space 1) blank line)
+  (call-with-input-string "\
+(list with
+
+      blank line)\n"
+    read-with-comments))
+
+(test-equal "read-with-comments: list with multiple blank lines"
+  `(list with ,(comment ";multiple\n" #t)
+         ,(vertical-space 3) blank lines)
+  (call-with-input-string "\
+(list with ;multiple
+
+
+
+      blank lines)\n"
+    read-with-comments))
+
+(test-equal "read-with-comments: top-level blank lines"
+  (list (vertical-space 2) '(a b c) (vertical-space 2))
+  (call-with-input-string "
+
+(a b c)\n\n"
+    (lambda (port)
+      (list (read-with-comments port)
+            (read-with-comments port)
+            (read-with-comments port)))))
+
 (test-pretty-print "(list 1 2 3 4)")
 (test-pretty-print "((a . 1) (b . 2))")
 (test-pretty-print "(a b c . boom)")
@@ -181,6 +211,24 @@ (define-syntax-rule (test-pretty-print str args ...)
    `(cons \"--without-any-problem\"
           ,flags)))")
 
+(test-pretty-print "\
+(vertical-space one:
+
+                two:
+
+
+                three:
+
+
+
+                end)")
+
+(test-pretty-print "\
+(vertical-space one
+
+                ;; Comment after blank line.
+                two)")
+
 (test-equal "pretty-print-with-comments, canonicalize-comment"
   "\
 (list abc
@@ -206,4 +254,30 @@ (define-syntax-rule (test-pretty-print str args ...)
                                     #:format-comment
                                     canonicalize-comment)))))
 
+(test-equal "pretty-print-with-comments, canonicalize-vertical-space"
+  "\
+(list abc
+
+      def
+
+      ;; last one
+      ghi)"
+  (let ((sexp (call-with-input-string
+                  "\
+(list abc
+
+
+
+  def
+
+
+;; last one
+  ghi)"
+                read-with-comments)))
+    (call-with-output-string
+      (lambda (port)
+        (pretty-print-with-comments port sexp
+                                    #:format-vertical-space
+                                    canonicalize-vertical-space)))))
+
 (test-end)
-- 
2.37.1

[bug#56898] [PATCH 07/13] read-print: Recognize page breaks.

[Ludovic Courtès]

* guix/read-print.scm (<page-break>, page-break?, page-break)
(char-set:whitespace-sans-page-break): New variables.
(space?): New procedure.
(read-vertical-space): Use it.
(read-until-end-of-line): New procedure.
(read-with-comments): Add #\page case.
(pretty-print-with-comments): Add 'page-break?' case.
* tests/read-print.scm ("read-with-comments: top-level page break"): New
test.
Add round-trip test with page break within an sexp.
---
 guix/read-print.scm  | 46 +++++++++++++++++++++++++++++++++++++++++---
 tests/read-print.scm | 22 +++++++++++++++++++++
 2 files changed, 65 insertions(+), 3 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 2b626ba281..33ed6e3dbe 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -35,6 +35,9 @@ (define-module (guix read-print)
             vertical-space-height
             canonicalize-vertical-space
 
+            page-break
+            page-break?
+
             comment
             comment?
             comment->string
@@ -83,6 +86,18 @@ (define canonicalize-vertical-space
       "Return a vertical space corresponding to a single blank line."
       unit)))
 
+(define <page-break>
+  (make-record-type '<page-break> '()
+                    #:parent <blank>
+                    #:extensible? #f))
+
+(define page-break?           (record-predicate <page-break>))
+(define page-break
+  (let ((break ((record-type-constructor <page-break>))))
+    (lambda ()
+      break)))
+
+
 (define <comment>
   ;; Comments.
   (make-record-type '<comment> '(str margin?)
@@ -105,12 +120,17 @@ (define* (comment str #:optional margin?)
             (&message (message "invalid comment string")))))
   (string->comment str margin?))
 
+(define char-set:whitespace-sans-page-break
+  ;; White space, excluding #\page.
+  (char-set-difference char-set:whitespace (char-set #\page)))
+
+(define (space? chr)
+  "Return true if CHR is white space, except for page breaks."
+  (char-set-contains? char-set:whitespace-sans-page-break chr))
+
 (define (read-vertical-space port)
   "Read from PORT until a non-vertical-space character is met, and return a
 single <vertical-space> record."
-  (define (space? chr)
-    (char-set-contains? char-set:whitespace chr))
-
   (let loop ((height 1))
     (match (read-char port)
       (#\newline (loop (+ 1 height)))
@@ -118,6 +138,15 @@ (define (space? chr)
       ((? space?) (loop height))
       (chr (unread-char chr port) (vertical-space height)))))
 
+(define (read-until-end-of-line port)
+  "Read white space from PORT until the end of line, included."
+  (let loop ()
+    (match (read-char port)
+      (#\newline #t)
+      ((? eof-object?) #t)
+      ((? space?) (loop))
+      (chr (unread-char chr port)))))
+
 (define (read-with-comments port)
   "Like 'read', but include <blank> objects when they're encountered."
   ;; Note: Instead of implementing this functionality in 'read' proper, which
@@ -148,6 +177,11 @@ (define (reverse/dot lst)
               (if blank-line?
                   (read-vertical-space port)
                   (loop #t return)))
+             ((eqv? chr #\page)
+              ;; Assume that a page break is on a line of its own and read
+              ;; subsequent white space and newline.
+              (read-until-end-of-line port)
+              (page-break))
              ((char-set-contains? char-set:whitespace chr)
               (loop blank-line? return))
              ((memv chr '(#\( #\[))
@@ -444,6 +478,12 @@ (define (special-form? head)
            (loop (- i 1))))
        (display (make-string indent #\space) port)
        indent)
+      ((? page-break?)
+       (unless delimited? (newline port))
+       (display #\page port)
+       (newline port)
+       (display (make-string indent #\space) port)
+       indent)
       (('quote lst)
        (unless delimited? (display " " port))
        (display "'" port)
diff --git a/tests/read-print.scm b/tests/read-print.scm
index f915b7e2d2..70be7754f8 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -70,6 +70,21 @@ (define-syntax-rule (test-pretty-print str args ...)
             (read-with-comments port)
             (read-with-comments port)))))
 
+(test-equal "read-with-comments: top-level page break"
+  (list (comment ";; Begin.\n") (vertical-space 1)
+        (page-break)
+        (comment ";; End.\n"))
+  (call-with-input-string "\
+;; Begin.
+
+\f
+;; End.\n"
+    (lambda (port)
+      (list (read-with-comments port)
+            (read-with-comments port)
+            (read-with-comments port)
+            (read-with-comments port)))))
+
 (test-pretty-print "(list 1 2 3 4)")
 (test-pretty-print "((a . 1) (b . 2))")
 (test-pretty-print "(a b c . boom)")
@@ -229,6 +244,13 @@ (define-syntax-rule (test-pretty-print str args ...)
                 ;; Comment after blank line.
                 two)")
 
+(test-pretty-print "\
+(begin
+  break
+\f
+  ;; page break above
+  end)")
+
 (test-equal "pretty-print-with-comments, canonicalize-comment"
   "\
 (list abc
-- 
2.37.1

[bug#56898] [PATCH 08/13] read-print: Add code to read and write sequences of expressions/blanks.

[Ludovic Courtès]

* guix/read-print.scm (read-with-comments): Add #:blank-line? and honor it.
(read-with-comments/sequence, pretty-print-with-comments/splice): New
procedures.
* tests/read-print.scm (test-pretty-print/sequence): New macro.
Add tests using it.
---
 guix/read-print.scm  | 32 +++++++++++++++++++++++++++++---
 tests/read-print.scm | 37 +++++++++++++++++++++++++++++++++++++
 2 files changed, 66 insertions(+), 3 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 33ed6e3dbe..4a3afdd4f9 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -25,7 +25,9 @@ (define-module (guix read-print)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (pretty-print-with-comments
+            pretty-print-with-comments/splice
             read-with-comments
+            read-with-comments/sequence
             object->string*
 
             blank?
@@ -147,8 +149,9 @@ (define (read-until-end-of-line port)
       ((? space?) (loop))
       (chr (unread-char chr port)))))
 
-(define (read-with-comments port)
-  "Like 'read', but include <blank> objects when they're encountered."
+(define* (read-with-comments port #:key (blank-line? #t))
+  "Like 'read', but include <blank> objects when they're encountered.  When
+BLANK-LINE? is true, assume PORT is at the beginning of a new line."
   ;; Note: Instead of implementing this functionality in 'read' proper, which
   ;; is the best approach long-term, this code is a layer on top of 'read',
   ;; such that we don't have to rely on a specific Guile version.
@@ -167,7 +170,7 @@ (define (reverse/dot lst)
            dotted))
         ((x . rest) (loop (cons x result) rest)))))
 
-  (let loop ((blank-line? #t)
+  (let loop ((blank-line? blank-line?)
              (return (const 'unbalanced)))
     (match (read-char port)
       ((? eof-object? eof)
@@ -217,6 +220,20 @@ (define (reverse/dot lst)
                 ((and token '#{.}#)
                  (if (eq? chr #\.) dot token))
                 (token token))))))))
+
+(define (read-with-comments/sequence port)
+  "Read from PORT until the end-of-file is reached and return the list of
+expressions and blanks that were read."
+  (let loop ((lst '())
+             (blank-line? #t))
+    (match (read-with-comments port #:blank-line? blank-line?)
+      ((? eof-object?)
+       (reverse! lst))
+      ((? blank? blank)
+       (loop (cons blank lst) #t))
+      (exp
+       (loop (cons exp lst) #f)))))
+
 \f
 ;;;
 ;;; Comment-preserving pretty-printer.
@@ -625,3 +642,12 @@ (define (object->string* obj indent . args)
       (apply pretty-print-with-comments port obj
              #:indent indent
              args))))
+
+(define* (pretty-print-with-comments/splice port lst
+                                            #:rest rest)
+  "Write to PORT the expressions and blanks listed in LST."
+  (for-each (lambda (exp)
+              (apply pretty-print-with-comments port exp rest)
+              (unless (blank? exp)
+                (newline port)))
+            lst))
diff --git a/tests/read-print.scm b/tests/read-print.scm
index 70be7754f8..94f018dd44 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -33,6 +33,16 @@ (define-syntax-rule (test-pretty-print str args ...)
                      read-with-comments)))
          (pretty-print-with-comments port exp args ...))))))
 
+(define-syntax-rule (test-pretty-print/sequence str args ...)
+  "Likewise, but read and print entire sequences rather than individual
+expressions."
+  (test-equal str
+    (call-with-output-string
+      (lambda (port)
+        (let ((lst (call-with-input-string str
+                     read-with-comments/sequence)))
+         (pretty-print-with-comments/splice port lst args ...))))))
+
 \f
 (test-begin "read-print")
 
@@ -251,6 +261,33 @@ (define-syntax-rule (test-pretty-print str args ...)
   ;; page break above
   end)")
 
+(test-pretty-print/sequence "\
+;;; This is a top-level comment.
+
+\f
+;; Above is a page break.
+(this is an sexp
+      ;; with a comment
+      !!)
+
+;; The end.\n")
+
+(test-pretty-print/sequence "
+;;; Hello!
+
+(define-module (foo bar)
+  #:use-module (guix)
+  #:use-module (gnu))
+
+
+;; And now, the OS.
+(operating-system
+  (host-name \"komputilo\")
+  (locale \"eo_EO.UTF-8\")
+
+  (services
+   (cons (service mcron-service-type) %base-services)))\n")
+
 (test-equal "pretty-print-with-comments, canonicalize-comment"
   "\
 (list abc
-- 
2.37.1

[bug#56898] [PATCH 09/13] read-print: 'canonicalize-comment' leaves top-level comments unchanged.

[Ludovic Courtès]

This lets users use three leading semicolons, for instance, in top-level
comments.

* guix/read-print.scm (canonicalize-comment): Add INDENT parameter and
honor it.
(pretty-print-with-comments): Change default value of #:format-comment.
Call FORMAT-COMMENT with INDENT as the second argument.
* tests/read-print.scm: Adjust test accordingly.
---
 guix/read-print.scm  | 35 +++++++++++++++++++----------------
 tests/read-print.scm |  4 +++-
 2 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 4a3afdd4f9..2fc3d85a25 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -371,23 +371,26 @@ (define (string-width str)
   "Return the \"width\" of STR--i.e., the width of the longest line of STR."
   (apply max (map string-length (string-split str #\newline))))
 
-(define (canonicalize-comment c)
-  "Canonicalize comment C, ensuring it has the \"right\" number of leading
-semicolons."
-  (let ((line (string-trim-both
-               (string-trim (comment->string c) (char-set #\;)))))
-    (string->comment (string-append
-                      (if (comment-margin? c)
-                          ";"
-                          (if (string-null? line)
-                              ";;"                        ;no trailing space
-                              ";; "))
-                      line "\n")
-                     (comment-margin? c))))
+(define (canonicalize-comment comment indent)
+  "Canonicalize COMMENT, which is to be printed at INDENT, ensuring it has the
+\"right\" number of leading semicolons."
+  (if (zero? indent)
+      comment                              ;leave top-level comments unchanged
+      (let ((line (string-trim-both
+                   (string-trim (comment->string comment) (char-set #\;)))))
+        (string->comment (string-append
+                          (if (comment-margin? comment)
+                              ";"
+                              (if (string-null? line)
+                                  ";;"            ;no trailing space
+                                  ";; "))
+                          line "\n")
+                         (comment-margin? comment)))))
 
 (define* (pretty-print-with-comments port obj
                                      #:key
-                                     (format-comment identity)
+                                     (format-comment
+                                      (lambda (comment indent) comment))
                                      (format-vertical-space identity)
                                      (indent 0)
                                      (max-width 78)
@@ -475,7 +478,7 @@ (define (special-form? head)
        (if (comment-margin? comment)
            (begin
              (display " " port)
-             (display (comment->string (format-comment comment))
+             (display (comment->string (format-comment comment indent))
                       port))
            (begin
              ;; When already at the beginning of a line, for example because
@@ -483,7 +486,7 @@ (define (special-form? head)
              (unless (= column indent)
                (newline port)
                (display (make-string indent #\space) port))
-             (display (comment->string (format-comment comment))
+             (display (comment->string (format-comment comment indent))
                       port)))
        (display (make-string indent #\space) port)
        indent)
diff --git a/tests/read-print.scm b/tests/read-print.scm
index 94f018dd44..e3f23194af 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -274,6 +274,7 @@ (define-syntax-rule (test-pretty-print/sequence str args ...)
 
 (test-pretty-print/sequence "
 ;;; Hello!
+;;; Notice that there are three semicolons here.
 
 (define-module (foo bar)
   #:use-module (guix)
@@ -286,7 +287,8 @@ (define-module (foo bar)
   (locale \"eo_EO.UTF-8\")
 
   (services
-   (cons (service mcron-service-type) %base-services)))\n")
+   (cons (service mcron-service-type) %base-services)))\n"
+                            #:format-comment canonicalize-comment)
 
 (test-equal "pretty-print-with-comments, canonicalize-comment"
   "\
-- 
2.37.1

[bug#56898] [PATCH 10/13] style: Add '--whole-file' option.

[Ludovic Courtès]

* guix/scripts/style.scm (format-whole-file): New procedure.
(%options, show-help): Add '--whole-file'.
(guix-style): Honor it.
* tests/guix-style.sh: New file.
* Makefile.am (SH_TESTS): Add it.
* doc/guix.texi (Invoking guix style): Document it.
---
 Makefile.am            |  1 +
 doc/guix.texi          | 28 +++++++++++++--
 guix/scripts/style.scm | 65 ++++++++++++++++++++++++----------
 tests/guix-style.sh    | 80 ++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 153 insertions(+), 21 deletions(-)
 create mode 100644 tests/guix-style.sh

diff --git a/Makefile.am b/Makefile.am
index 2cda20e61c..f7c42e8153 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -580,6 +580,7 @@ SH_TESTS =					\
   tests/guix-package.sh				\
   tests/guix-package-aliases.sh			\
   tests/guix-package-net.sh			\
+  tests/guix-style.sh				\
   tests/guix-system.sh				\
   tests/guix-home.sh				\
   tests/guix-archive.sh				\
diff --git a/doc/guix.texi b/doc/guix.texi
index fc6f477c9a..8dd1e306de 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14058,9 +14058,12 @@ 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 provides the following styling rules:
+The @command{guix style} command helps users and packagers alike style
+their package definitions and configuration files according to the
+latest fashionable trends.  It can either reformat whole files, with the
+@option{--whole-file} option, or apply specific @dfn{styling rules} to
+individual package definitions.  The command currently provides the
+following styling rules:
 
 @itemize
 @item
@@ -14115,6 +14118,12 @@ the packages.  The @option{--styling} or @option{-S} option allows you
 to select the style rule, the default rule being @code{format}---see
 below.
 
+To reformat entire source files, the syntax is:
+
+@example
+guix style --whole-file @var{file}@dots{}
+@end example
+
 The available options are listed below.
 
 @table @code
@@ -14122,6 +14131,19 @@ The available options are listed below.
 @itemx -n
 Show source file locations that would be edited but do not modify them.
 
+@item --whole-file
+@itemx -f
+Reformat the given files in their entirety.  In that case, subsequent
+arguments are interpreted as file names (rather than package names), and
+the @option{--styling} option has no effect.
+
+As an example, here is how you might reformat your operating system
+configuration (you need write permissions for the file):
+
+@example
+guix style -f /etc/config.scm
+@end example
+
 @item --styling=@var{rule}
 @itemx -S @var{rule}
 Apply @var{rule}, one of the following styling rules:
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 2e14bc68fd..c0b9ea1a28 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -328,6 +328,21 @@ (define (package-location<? p1 p2)
              (< (location-line loc1) (location-line loc2))
              (string<? (location-file loc1) (location-file loc2))))))
 
+\f
+;;;
+;;; Whole-file formatting.
+;;;
+
+(define* (format-whole-file file #:rest rest)
+  "Reformat all of FILE."
+  (let ((lst (call-with-input-file file read-with-comments/sequence)))
+    (with-atomic-file-output file
+      (lambda (port)
+        (apply pretty-print-with-comments/splice port lst
+               #:format-comment canonicalize-comment
+               #:format-vertical-space canonicalize-vertical-space
+               rest)))))
+
 \f
 ;;;
 ;;; Options.
@@ -345,6 +360,9 @@ (define %options
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
+        (option '(#\f "whole-file") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'whole-file? #t result)))
         (option '(#\S "styling") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'styling-procedure
@@ -400,6 +418,9 @@ (define (show-help)
                          of 'silent', 'safe', or 'always'"))
   (newline)
   (display (G_ "
+  -f, --whole-file       format the entire contents of the given file(s)"))
+  (newline)
+  (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
   -V, --version          display version information and exit"))
@@ -426,27 +447,35 @@ (define (parse-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))
          (edit     (if (assoc-ref opts 'dry-run?)
                        edit-expression/dry-run
                        edit-expression))
          (style    (assoc-ref opts 'styling-procedure))
          (policy   (assoc-ref opts 'input-simplification-policy)))
     (with-error-handling
-      (for-each (lambda (package)
-                  (style package #:policy policy
-                         #:edit-expression edit))
-                ;; 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<?))))))
+      (if (assoc-ref opts 'whole-file?)
+          (let ((files (filter-map (match-lambda
+                                     (('argument . file) file)
+                                     (_ #f))
+                                   opts)))
+            (unless (eq? format-package-definition style)
+              (warning (G_ "'--styling' option has no effect in whole-file mode~%")))
+            (for-each format-whole-file files))
+          (let ((packages (filter-map (match-lambda
+                                        (('argument . spec)
+                                         (specification->package spec))
+                                        (('expression . str)
+                                         (read/eval str))
+                                        (_ #f))
+                                      opts)))
+            (for-each (lambda (package)
+                        (style package #:policy policy
+                               #:edit-expression edit))
+                      ;; 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/tests/guix-style.sh b/tests/guix-style.sh
new file mode 100644
index 0000000000..58f953a0ec
--- /dev/null
+++ b/tests/guix-style.sh
@@ -0,0 +1,80 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2022 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/>.
+
+#
+# Test 'guix style'.
+#
+
+set -e
+
+guix style --version
+
+tmpdir="guix-style-$$"
+trap 'rm -r "$tmpdir"' EXIT
+
+tmpfile="$tmpdir/os.scm"
+mkdir "$tmpdir"
+cat > "$tmpfile" <<EOF
+;;; This is a header with three semicolons.
+;;;
+
+(define-module (foo bar)
+  #:use-module (guix)
+  #:use-module (gnu))
+
+;; One blank line and a page break.
+
+\f
+;; And now, the OS.
+(operating-system
+  (host-name "komputilo")
+  (locale "eo_EO.UTF-8")
+
+  ;; User accounts.
+  (users (cons (user-account
+                 (name "alice")
+                 (comment "Bob's sister")
+                 (group "users")
+
+                 ;; Groups fit on one line.
+                 (supplementary-groups '("wheel" "audio" "video")))
+               %base-user-accounts))
+
+  ;; The services.
+  (services
+   (cons (service mcron-service-type) %base-services)))
+EOF
+
+cp "$tmpfile" "$tmpfile.bak"
+
+initial_hash="$(guix hash "$tmpfile")"
+
+guix style -f "$tmpfile"
+if ! test "$initial_hash" = "$(guix hash "$tmpfile")"
+then
+    cat "$tmpfile"
+    diff -u "$tmpfile.bak" "$tmpfile"
+    false
+fi
+
+# Introduce random changes and try again.
+sed -i "$tmpfile" -e's/ +/ /g'
+! test "$initial_hash" = "$(guix hash "$tmpfile")"
+
+guix style -f "$tmpfile"
+test "$initial_hash" = "$(guix hash "$tmpfile")"
-- 
2.37.1

[bug#56898] [PATCH 11/13] read-print: Support printing multi-line comments.

[Ludovic Courtès]

* guix/read-print.scm (%not-newline): New variable.
(print-multi-line-comment): New procedure.
(pretty-print-with-comments): Use it.
* tests/read-print.scm ("pretty-print-with-comments, multi-line
comment"): New test.
---
 guix/read-print.scm  | 26 ++++++++++++++++++++++++--
 tests/read-print.scm | 14 ++++++++++++++
 2 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 2fc3d85a25..df25eb0f50 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -387,6 +387,27 @@ (define (canonicalize-comment comment indent)
                           line "\n")
                          (comment-margin? comment)))))
 
+(define %not-newline
+  (char-set-complement (char-set #\newline)))
+
+(define (print-multi-line-comment str indent port)
+  "Print to PORT STR as a multi-line comment, with INDENT spaces preceding
+each line except the first one (they're assumed to be already there)."
+
+  ;; While 'read-with-comments' only returns one-line comments, user-provided
+  ;; comments might span multiple lines, which is why this is necessary.
+  (let loop ((lst (string-tokenize str %not-newline)))
+    (match lst
+      (() #t)
+      ((last)
+       (display last port)
+       (newline port))
+      ((head tail ...)
+       (display head port)
+       (newline port)
+       (display (make-string indent #\space) port)
+       (loop tail)))))
+
 (define* (pretty-print-with-comments port obj
                                      #:key
                                      (format-comment
@@ -486,8 +507,9 @@ (define (special-form? head)
              (unless (= column indent)
                (newline port)
                (display (make-string indent #\space) port))
-             (display (comment->string (format-comment comment indent))
-                      port)))
+             (print-multi-line-comment (comment->string
+                                        (format-comment comment indent))
+                                       indent port)))
        (display (make-string indent #\space) port)
        indent)
       ((? vertical-space? space)
diff --git a/tests/read-print.scm b/tests/read-print.scm
index e3f23194af..004fcff19f 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -341,4 +341,18 @@ (define-module (foo bar)
                                     #:format-vertical-space
                                     canonicalize-vertical-space)))))
 
+(test-equal "pretty-print-with-comments, multi-line comment"
+  "\
+(list abc
+      ;; This comment spans
+      ;; two lines.
+      def)"
+  (call-with-output-string
+    (lambda (port)
+      (pretty-print-with-comments port
+                                  `(list abc ,(comment "\
+;; This comment spans\n
+;; two lines.\n")
+                                         def)))))
+
 (test-end)
-- 
2.37.1

[bug#56898] [PATCH 12/13] installer: Render the final configuration with (guix read-print).

[Ludovic Courtès]

* gnu/installer.scm (module-to-import?): Return #t for (guix read-print).
* gnu/installer/steps.scm (configuration->file): Use
'pretty-print-with-comments/splice' instead of 'for-each' and 'pretty-print'.
---
 gnu/installer.scm       |  3 ++-
 gnu/installer/steps.scm | 12 +++++-------
 2 files changed, 7 insertions(+), 8 deletions(-)

diff --git a/gnu/installer.scm b/gnu/installer.scm
index 415f5a7af7..8a6e604fa5 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;;
@@ -63,6 +63,7 @@ (define module-to-import?
     (('gnu 'installer _ ...) #t)
     (('gnu 'build _ ...) #t)
     (('guix 'build _ ...) #t)
+    (('guix 'read-print) #t)
     (_ #f)))
 
 (define not-config?
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 8bc38181a7..f1d61a2bc5 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,9 +21,9 @@ (define-module (gnu installer steps)
   #:use-module (guix records)
   #:use-module (guix build utils)
   #:use-module (guix i18n)
+  #:use-module (guix read-print)
   #:use-module (gnu installer utils)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -244,11 +244,9 @@ (define* (configuration->file configuration
 ;; by the graphical installer.\n")
                port)
       (newline port)
-      (for-each (lambda (part)
-                  (if (null? part)
-                      (newline port)
-                      (pretty-print part port)))
-                configuration)
+      (pretty-print-with-comments/splice port configuration
+                                         #:max-width 75)
+
       (flush-output-port port))))
 
 ;;; Local Variables:
-- 
2.37.1

[bug#56898] [PATCH 13/13] installer: Add comments and vertical space to the generated config.

[Ludovic Courtès]

* gnu/installer/parted.scm (user-partitions->configuration): Introduce
vertical space and a comment.
* gnu/installer/services.scm (G_): New macro.
(%system-services): Add comment for OpenSSH.
(system-services->configuration): Add vertical space and comments.
* gnu/installer/user.scm (users->configuration): Add comment.
* gnu/installer/steps.scm (format-configuration): Add comment.
(configuration->file): Expound leading comment.  Pass #:format-comment
to 'pretty-print-with-comments/splice'.
---
 gnu/installer/parted.scm   | 10 +++++++++-
 gnu/installer/services.scm | 39 ++++++++++++++++++++++++++++++--------
 gnu/installer/steps.scm    | 22 +++++++++++++++++----
 gnu/installer/user.scm     |  7 ++++++-
 4 files changed, 64 insertions(+), 14 deletions(-)

diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 94ef9b42bc..9a57d13452 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -38,6 +38,7 @@ (define-module (gnu installer parted)
                 #:select (%base-initrd-modules))
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
+  #:use-module (guix read-print)
   #:use-module (guix records)
   #:use-module (guix utils)
   #:use-module (guix i18n)
@@ -1439,6 +1440,13 @@ (define (user-partitions->configuration user-partitions)
             `((mapped-devices
                (list ,@(map user-partition->mapped-device
                             encrypted-partitions)))))
+
+      ,(vertical-space 1)
+      ,(let-syntax ((G_ (syntax-rules () ((_ str) str))))
+         (comment (G_ "\
+;; The list of file systems that get \"mounted\".  The unique
+;; file system identifiers there (\"UUIDs\") can be obtained
+;; by running 'blkid' in a terminal.\n")))
       (file-systems (cons*
                      ,@(user-partitions->file-systems user-partitions)
                      %base-file-systems)))))
diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm
index 6584fcceec..6c5f49622f 100644
--- a/gnu/installer/services.scm
+++ b/gnu/installer/services.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
@@ -22,6 +22,7 @@
 
 (define-module (gnu installer services)
   #:use-module (guix records)
+  #:use-module (guix read-print)
   #:use-module (srfi srfi-1)
   #:export (system-service?
             system-service-name
@@ -35,6 +36,11 @@ (define-module (gnu installer services)
             %system-services
             system-services->configuration))
 
+(define-syntax-rule (G_ str)
+  ;; In this file, translatable strings are annotated with 'G_' so xgettext
+  ;; catches them, but translation happens later on at run time.
+  str)
+
 (define-record-type* <system-service>
   system-service make-system-service
   system-service?
@@ -52,9 +58,7 @@ (define %system-services
                                       ((_ fields ...)
                                        (system-service
                                         (type 'desktop)
-                                        fields ...))))
-               (G_ (syntax-rules ()               ;for xgettext
-                     ((_ str) str))))
+                                        fields ...)))))
     (list
      ;; This is the list of desktop environments supported as services.
      (desktop-environment
@@ -94,7 +98,12 @@ (define %system-services
      (system-service
       (name (G_ "OpenSSH secure shell daemon (sshd)"))
       (type 'networking)
-      (snippet '((service openssh-service-type))))
+      (snippet `(,(vertical-space 1)
+                 ,(comment
+                   (G_ "\
+;; To configure OpenSSH, pass an 'openssh-configuration'
+;; record as a second argument to 'service' below.\n"))
+                 (service openssh-service-type))))
      (system-service
       (name (G_ "Tor anonymous network router"))
       (type 'networking)
@@ -149,24 +158,38 @@ (define (system-services->configuration services)
          (desktop? (find desktop-system-service? services))
          (base     (if desktop?
                        '%desktop-services
-                       '%base-services)))
+                       '%base-services))
+         (heading  (list (vertical-space 1)
+                         (comment (G_ "\
+;; Below is the list of system services.  To search for available
+;; services, run 'guix system search KEYWORD' in a terminal.\n")))))
+
     (if (null? snippets)
         `(,@(if (null? packages)
                 '()
                 `((packages (append (list ,@packages)
                                     %base-packages))))
+
+          ,@heading
           (services ,base))
         `(,@(if (null? packages)
                 '()
                 `((packages (append (list ,@packages)
                                     %base-packages))))
+
+          ,@heading
           (services (append (list ,@snippets
 
                                   ,@(if desktop?
                                         ;; XXX: Assume 'keyboard-layout' is in
                                         ;; scope.
-                                        '((set-xorg-configuration
+                                        `((set-xorg-configuration
                                            (xorg-configuration
                                             (keyboard-layout keyboard-layout))))
                                         '()))
-                           ,base))))))
+
+                            ,(vertical-space 1)
+                            ,(comment (G_ "\
+;; This is the default list of services we
+;; are appending to.\n"))
+                            ,base))))))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index f1d61a2bc5..8b25ae97c8 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -224,10 +224,14 @@ (define (format-configuration steps results)
                   (conf-formatter result-step)
                   '())))
           steps))
-        (modules '((use-modules (gnu))
+        (modules `(,(vertical-space 1)
+                   ,(comment (G_ "\
+;; Indicate which modules to import to access the variables
+;; used in this configuration.\n"))
+                   (use-modules (gnu))
                    (use-service-modules cups desktop networking ssh xorg))))
     `(,@modules
-      ()
+      ,(vertical-space 1)
       (operating-system ,@configuration))))
 
 (define* (configuration->file configuration
@@ -241,11 +245,21 @@ (define* (configuration->file configuration
       ;; length below 60 characters.
       (display (G_ "\
 ;; This is an operating system configuration generated
-;; by the graphical installer.\n")
+;; by the graphical installer.
+;;
+;; Once installation is complete, you can learn and modify
+;; this file to tweak the system configuration, and pass it
+;; to the 'guix system reconfigure' command to effect your
+;; changes.\n")
                port)
       (newline port)
       (pretty-print-with-comments/splice port configuration
-                                         #:max-width 75)
+                                         #:max-width 75
+                                         #:format-comment
+                                         (lambda (c indent)
+                                           ;; Localize C.
+                                           (comment (G_ (comment->string c))
+                                                    (comment-margin? c))))
 
       (flush-output-port port))))
 
diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm
index c894a91dc8..224040530c 100644
--- a/gnu/installer/user.scm
+++ b/gnu/installer/user.scm
@@ -18,6 +18,7 @@
 
 (define-module (gnu installer user)
   #:use-module (guix records)
+  #:use-module (guix read-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -69,7 +70,11 @@ (define (user->sexp user)
       (supplementary-groups '("wheel" "netdev"
                               "audio" "video"))))
 
-  `((users (cons*
+  (define-syntax-rule (G_ str) str)
+
+  `(,(vertical-space 1)
+    ,(comment (G_ ";; The list of user accounts ('root' is implicit).\n"))
+    (users (cons*
             ,@(filter-map (lambda (user)
                             ;; Do not emit a 'user-account' form for "root".
                             (and (not (string=? (user-name user) "root"))
-- 
2.37.1

[bug#56898] [PATCH 00/13] Put the pretty printer to good use

[Mathieu Othacehe]

Hey Ludo,

Wow, nice! I tested the installer part, everything seems to work fine
and the new comments are a welcomed addition.

Thanks,

Mathieu

[bug#56898] [PATCH 00/13] Put the pretty printer to good use

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <othacehe@gnu.org> skribis:

> Wow, nice! I tested the installer part, everything seems to work fine
> and the new comments are a welcomed addition.

Thanks for taking a look, I’m glad you liked it!

I guess we could add more comments in the generated OS config to guide
people; I wasn’t sure where to add them and how to frame them, but we
can do that later.

Ludo’.

bug#56898: [PATCH 00/13] Put the pretty printer to good use

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   style: Move reader and printer to (guix read-print).
>   read-print: Add System and Home special forms.
>   read-print: Expose comment constructor.
>   read-print: Introduce <blank> parent class of <comment>.
>   style: Adjust test to not emit blank lines.
>   read-print: Read and render vertical space.
>   read-print: Recognize page breaks.
>   read-print: Add code to read and write sequences of
>     expressions/blanks.
>   read-print: 'canonicalize-comment' leaves top-level comments
>     unchanged.
>   style: Add '--whole-file' option.
>   read-print: Support printing multi-line comments.
>   installer: Render the final configuration with (guix read-print).
>   installer: Add comments and vertical space to the generated config.

Oops, forgot to close: I pushed this series as
ff9522fb69b9f4a31a5b766029e26dc53a2d1cf8 yesterday.

Lemme know how it goes!

Ludo’.