Merge branch 'staging' into core-updates

author: Marius Bakke <marius@gnu.org> 2022-08-11 23:36:10 +0200
committer: Marius Bakke <marius@gnu.org> 2022-08-11 23:36:10 +0200
commit: 77eb3008e350c069e0ae8df6a91bf0ebdcfc2ac0 (patch)
tree: b899e65aa79099be3f4b27dfcd565bb143681211 /tests
parent: f7e8be231806a904e6817e8ab3404b32f2511db2 (diff)
parent: b50eaa67642ebc25e9c896f2e700c08610e0a5da (diff)
5 files changed, 488 insertions, 188 deletions
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index 1d1acbfd6e..d5e2dadbb5 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -107,7 +107,10 @@ EOF
 
     if container_supported
     then
-	# Run the home in a container.
+	# Run the home in a container.  Always use bash inside container for
+        # reproducibility of the tests.
+        # TODO: Make container independent from external environment variables.
+        SHELL=bash
 	guix home container home.scm -- true
 	! guix home container home.scm -- false
 	test "$(guix home container home.scm -- echo '$HOME')" = "$HOME"
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.
+
+
+;; 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")"
diff --git a/tests/read-print.scm b/tests/read-print.scm
new file mode 100644
index 0000000000..4dabcc1e64
--- /dev/null
+++ b/tests/read-print.scm
@@ -0,0 +1,380 @@
+;;; 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-34)
+  #:use-module (srfi srfi-35)
+  #: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
+'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 ...))))))
+
+(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 ...))))))
+
+
+(test-begin "read-print")
+
+(test-assert "read-with-comments: missing closing paren"
+  (guard (c ((error? c) #t))
+    (call-with-input-string "(what is going on?"
+      read-with-comments)))
+
+(test-equal "read-with-comments: dot notation"
+  (cons 'a 'b)
+  (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-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.
+
+
+;; 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)")
+(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 "\
+(case x
+  ((1)
+   'one)
+  ((2)
+   'two))")
+
+(test-pretty-print "\
+(cond
+  ((zero? x)
+   'zero)
+  ((odd? x)
+   'odd)
+  (else #f))")
+
+(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-pretty-print "\
+(vertical-space one:
+
+                two:
+
+
+                three:
+
+
+
+                end)")
+
+(test-pretty-print "\
+(vertical-space one
+
+                ;; Comment after blank line.
+                two)")
+
+(test-pretty-print "\
+(begin
+  break
+
+  ;; page break above
+  end)")
+
+(test-pretty-print/sequence "\
+;;; This is a top-level comment.
+
+
+;; Above is a page break.
+(this is an sexp
+      ;; with a comment
+      !!)
+
+;; The end.\n")
+
+(test-pretty-print/sequence "
+;;; Hello!
+;;; Notice that there are three semicolons here.
+
+(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"
+                            #:format-comment canonicalize-comment)
+
+(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-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-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)
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 6268525317..649dad26e8 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
@@ -141,6 +141,24 @@
    (config-with-maybe-number
     (port 42))))
 
+(define (serialize-symbol name value)
+  (format #f "~a=~a~%" name value))
+
+(define-maybe symbol)
+
+(define-configuration config-with-maybe-symbol
+  (protocol maybe-symbol ""))
+
+;;; Maybe symbol values are currently seen as serializable, because the
+;;; unspecified value is 'unset, which is a symbol itself.
+;;; TODO: Remove expected fail marker after resolution.
+(test-expect-fail 1)
+(test-equal "symbol maybe value serialization, unspecified"
+  ""
+  (gexp->approximate-sexp
+   (serialize-configuration (config-with-maybe-symbol)
+                            config-with-maybe-symbol-fields)))
+
 (define-maybe/no-serialization string)
 
 (define-configuration config-with-maybe-string/no-serialization
@@ -151,9 +169,9 @@
   (not (defined? 'serialize-maybe-string)))
 
 (test-assert "maybe type, no default"
-  (unspecified?
-   (config-with-maybe-string/no-serialization-name
-    (config-with-maybe-string/no-serialization))))
+  (eq? 'unset
+       (config-with-maybe-string/no-serialization-name
+        (config-with-maybe-string/no-serialization))))
 
 (test-assert "maybe type, with default"
   (equal?
diff --git a/tests/style.scm b/tests/style.scm
index 55bad2b3ba..6aab2c3785 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -113,17 +113,6 @@
       (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 ...))))))
-
 
 (test-begin "style")
 
@@ -366,9 +355,9 @@
 
       (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")
@@ -377,176 +366,6 @@
       (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)
author	Marius Bakke <marius@gnu.org>	2022-08-11 23:36:10 +0200
committer	Marius Bakke <marius@gnu.org>	2022-08-11 23:36:10 +0200
commit	77eb3008e350c069e0ae8df6a91bf0ebdcfc2ac0 (patch)
tree	b899e65aa79099be3f4b27dfcd565bb143681211 /tests
parent	f7e8be231806a904e6817e8ab3404b32f2511db2 (diff)
parent	b50eaa67642ebc25e9c896f2e700c08610e0a5da (diff)