Merge branch 'master' into core-updates

3 files changed, 73 insertions, 35 deletions

diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 334a1e409b..6268525317 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Maxim Cournoyer <[email protected]>
 ;;; Copyright © 2021 Xinglu Chen <[email protected]>
+;;; Copyright © 2022 Ludovic Courtès <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,7 @@
 
 (define-module (tests services configuration)
   #:use-module (gnu services configuration)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64))
@@ -43,6 +45,17 @@
   80
   (port-configuration-port (port-configuration)))
 
+(test-equal "wrong type for a field"
+  '("configuration.scm" 57 11)                    ;error location
+  (guard (c ((configuration-error? c)
+             (let ((loc (error-location c)))
+               (list (basename (location-file loc))
+                     (location-line loc)
+                     (location-column loc)))))
+    (port-configuration
+     ;; This is line 56; the test relies on line/column numbers!
+     (port "This is not a number!"))))
+
 (define-configuration port-configuration-cs
   (port (number 80) "The port number." empty-serializer))
 
diff --git a/tests/status.scm b/tests/status.scm
index 01a61f7345..b0af619872 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <[email protected]>
+;;; Copyright © 2018, 2019, 2022 Ludovic Courtès <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,8 +19,8 @@
 (define-module (test-status)
   #:use-module (guix status)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match))
@@ -29,8 +29,7 @@
 
 (test-equal "compute-status, no-op"
   (build-status)
-  (let-values (((port get-status)
-                (build-event-output-port compute-status)))
+  (let ((port get-status (build-event-output-port compute-status)))
     (display "foo\nbar\n\baz\n" port)
     (get-status)))
 
@@ -53,11 +52,11 @@
                                               #:transferred 500
                                               #:start 'now
                                               #:end 'now)))))
-  (let-values (((port get-status)
-                (build-event-output-port (lambda (event status)
-                                           (compute-status event status
-                                                           #:current-time
-                                                           (const 'now))))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
     (display "@ build-started foo.drv - x86_64-linux \n" port)
     (display "@ substituter-started bar\n" port)
     (display "@ download-started bar http://example.org/bar 500\n" port)
@@ -100,11 +99,11 @@
                                               #:start 'now
                                               #:end 'now)))))
   ;; Below we omit 'substituter-started' events and the like.
-  (let-values (((port get-status)
-                (build-event-output-port (lambda (event status)
-                                           (compute-status event status
-                                                           #:current-time
-                                                           (const 'now))))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
     (display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
     (display "@ download-started bar http://example.org/bar 999\n" port)
     (display "various\nthings\nget\nwritten\n" port)
@@ -119,17 +118,31 @@
 
 (test-equal "build-output-port, UTF-8"
   '((build-log #f "lambda is λ!\n"))
-  (let-values (((port get-status) (build-event-output-port cons '()))
-               ((bv)              (string->utf8 "lambda is λ!\n")))
+  (let ((port get-status (build-event-output-port cons '()))
+        (bv              (string->utf8 "lambda is λ!\n")))
     (put-bytevector port bv)
     (force-output port)
     (get-status)))
 
+(test-equal "build-output-port, daemon messages with LF"
+  '((build-log #f "updating substitutes... 0%\r")
+    (build-log #f "updating substitutes... 50%\r")
+    (build-log #f "updating substitutes... 100%\r"))
+  (let ((port get-status (build-event-output-port cons '())))
+    (for-each (lambda (suffix)
+                (let ((bv (string->utf8
+                           (string-append "updating substitutes... "
+                                          suffix "\r"))))
+                  (put-bytevector port bv)
+                  (force-output port)))
+              '("0%" "50%" "100%"))
+    (reverse (get-status))))
+
 (test-equal "current-build-output-port, UTF-8 + garbage"
   ;; What about a mixture of UTF-8 + garbage?
   (let ((replacement "�"))
     `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
-  (let-values (((port get-status) (build-event-output-port cons '())))
+  (let ((port get-status (build-event-output-port cons '())))
     (display "garbage: " port)
     (put-bytevector port #vu8(128))
     (put-bytevector port (string->utf8 "lambda: λ\n"))
@@ -156,14 +169,14 @@
                                               #:transferred 999
                                               #:start 'now
                                               #:end 'now)))))
-  (let-values (((port get-status)
-                (build-event-output-port (lambda (event status)
-                                           (compute-status event status
-                                                           #:current-time
-                                                           (const 'now)
-                                                           #:derivation-path->output-path
-                                                           (match-lambda
-                                                             ("bar.drv" "bar")))))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now)
+                                                         #:derivation-path->output-path
+                                                         (match-lambda
+                                                           ("bar.drv" "bar")))))))
     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
     (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
     (display "@ build-log 121 6\nHello!" port)
@@ -192,11 +205,11 @@
         (build-status
          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
                                         #:completion 100.)))))
-  (let-values (((port get-status)
-                (build-event-output-port (lambda (event status)
-                                           (compute-status event status
-                                                           #:current-time
-                                                           (const 'now))))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
     (display "@ build-log 121 6\nHello!" port)
     (let ((first (get-status)))
@@ -225,11 +238,11 @@
         (build-status
          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
                                         #:phase 'install)))))
-  (let-values (((port get-status)
-                (build-event-output-port (lambda (event status)
-                                           (compute-status event status
-                                                           #:current-time
-                                                           (const 'now))))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
     (display "@ build-log 121 27\nstarting phase `configure'\n" port)
     (display "@ build-log 121 6\nabcde!" port)
diff --git a/tests/style.scm b/tests/style.scm
index 41f7e31cce..48d975df94 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -492,6 +492,18 @@ mnopqrstuvwxyz.\")"
    '(#: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-equal "pretty-print-with-comments, canonicalize-comment"
   "\
 (list abc