[bug#42146] [PATCH 2/3] build: substitute: Error when no substitutions were done.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

From: Jakub Kądziołka <kuba@kadziolka.net>

* guix/build/utils.scm (substitute, substitute*)
[require-matches?]: New argument.
* tests/build-utils.scm ("substitute*"): New test group.
("substitute*, no match error")
("substitute*, partial no match error"): New tests.

Co-authored-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Change-Id: I66ed33d72aa73cd35e5642521efec70bf756f86e
---
 guix/build/utils.scm  | 94 +++++++++++++++++++++++++++++++++----------
 tests/build-utils.scm | 63 +++++++++++++++++++----------
 2 files changed, 114 insertions(+), 43 deletions(-)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 2b3a8e278b..7bfb6560e1 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -6,7 +6,8 @@
 ;;; Copyright © 2018, 2022 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020, 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
 ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com>
@@ -971,24 +972,53 @@ (define (replace-char c1 c2 s)
                         c))
                   s)))
 
-(define (substitute file pattern+procs)
+(define* (substitute file pattern+procs #:key (require-matches? #t))
   "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs.  For each
 line of FILE, and for each PATTERN that it matches, call the corresponding
 PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
 a substitution of the original line.  Be careful about using '$' to match the
-end of a line; by itself it won't match the terminating newline of a line."
-  (let ((rx+proc  (map (match-lambda
-                        (((? regexp? pattern) . proc)
+end of a line; by itself it won't match the terminating newline of a line.
+
+By default, SUBSTITUTE will raise a &message condition if one of the patterns
+fails to match.  REQUIRE-MATCHES? can be set to false when lack of matches is
+acceptable (e.g. if you have multiple potential patterns not guaranteed to be
+found in FILE)."
+  (define (rx->pattern m)
+    (match m
+      ((? regexp? pattern)
+       "<unknown pattern (regexp)>")
+      ((? regexp*? pattern)
+       (regexp*-pattern pattern))
+      ((? string? pattern)
+       pattern)))
+
+  (define (make-condition failed-matches)
+    (condition
+     (&message
+      (message (format #f "substitute: `~a': no match for patterns `~a'"
+                       file failed-matches)))))
+
+  (let ((rx+proc (map (match-lambda
+                        (((or (? regexp? pattern) (? regexp*? pattern)) . proc)
                          (cons pattern proc))
                         ((pattern . proc)
-                         (cons (make-regexp pattern regexp/extended)
-                               proc)))
-                       pattern+procs)))
+                         (cons (make-regexp* pattern regexp/extended) proc)))
+                      pattern+procs)))
     (with-atomic-file-replacement file
       (lambda (in out)
-        (let loop ((line (read-line in 'concat)))
+        (let loop ((line (read-line in 'concat))
+                   (ok-matches '())
+                   (failed-matches '()))
           (if (eof-object? line)
-              #t
+              (when require-matches?
+                (let ((failed-patterns (lset-difference
+                                        string=?
+                                        (delete-duplicates
+                                         (map rx->pattern failed-matches))
+                                        (delete-duplicates
+                                         (map rx->pattern ok-matches)))))
+                  (when (not (null? failed-patterns))
+                    (raise (make-condition failed-patterns)))))
               ;; Work around the fact that Guile's regexp-exec does not handle
               ;; NUL characters (a limitation of the underlying GNU libc's
               ;; regexec) by temporarily replacing them by an unused private
@@ -998,19 +1028,30 @@ (define (substitute file pattern+procs)
                                     (unused-private-use-code-point line))
                                #\nul))
                      (line* (replace-char #\nul nul* line))
-                     (line1* (fold (lambda (r+p line)
-                                     (match r+p
-                                       ((regexp . proc)
-                                        (match (list-matches regexp line)
-                                          ((and m+ (_ _ ...))
-                                           (proc line m+))
-                                          (_ line)))))
-                                   line*
-                                   rx+proc))
+                     (results           ;line, ok-matches and failed-matches
+                      (fold (lambda (r+p results)
+                              (let ((line (first results))
+                                    (ok-matches (second results))
+                                    (failed-matches (third results)))
+                                (match r+p
+                                  ((regexp . proc)
+                                   (match (list-matches* regexp line)
+                                     ((and m+ (_ _ ...))
+                                      (list (proc line m+)
+                                            (cons regexp ok-matches)
+                                            failed-matches))
+                                     (_
+                                      (list line
+                                            ok-matches
+                                            (cons regexp failed-matches))))))))
+                            (list line* '() '())
+                            rx+proc))
+                     (line1* (first results))
+                     (ok-matches (second results))
+                     (failed-matches (third results))
                      (line1 (replace-char nul* #\nul line1*)))
                 (display line1 out)
-                (loop (read-line in 'concat)))))))))
-
+                (loop (read-line in 'concat) ok-matches failed-matches))))))))
 
 (define-syntax let-matches
   ;; Helper macro for `substitute*'.
@@ -1048,9 +1089,17 @@ (define-syntax substitute*
 Alternatively, FILE may be a list of file names, in which case they are
 all subject to the substitutions.
 
+By default, SUBSTITUTE* will raise a &message condition if one of the patterns
+fails to match on one of the files; REQUIRE-MATCHES? may be set to false to
+avoid an error being raised in such condition.
+
 Be careful about using '$' to match the end of a line; by itself it won't
 match the terminating newline of a line."
     ((substitute* file ((regexp match-var ...) body ...) ...)
+     (substitute* file #:require-matches? #t
+                  ((regexp match-var ...) body ...) ...))
+    ((substitute* file #:require-matches? require-matches?
+                  ((regexp match-var ...) body ...) ...)
      (let ()
        (define (substitute-one-file file-name)
          (substitute
@@ -1074,7 +1123,8 @@ (define-syntax substitute*
                                       (begin body ...)
                                       (substring l o (match:start m))
                                       r))))))))
-                ...)))
+                ...)
+          #:require-matches? require-matches?))
 
        (match file
          ((files (... ...))
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 3babf5d544..890fbca16f 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
 ;;;
@@ -289,26 +289,47 @@ (define (arg-test bash-args)
 (test-assert "wrap-script, argument handling, bash --norc"
   (arg-test " --norc"))
 
-(test-equal "substitute*, text contains a NUL byte, UTF-8"
-  "c\0d"
-  (with-fluids ((%default-port-encoding "UTF-8")
-                (%default-port-conversion-strategy 'error))
-    ;; The GNU libc is locale sensitive.  Depending on the value of LANG, the
-    ;; test could fail with "string contains #\\nul character: ~S" or "cannot
-    ;; convert wide string to output locale".
-    (setlocale LC_ALL "en_US.UTF-8")
-    (call-with-temporary-output-file
-     (lambda (file port)
-       (format port "a\0b")
-       (flush-output-port port)
-
-       (substitute* file
-         (("a") "c")
-         (("b") "d"))
-
-       (with-input-from-file file
-         (lambda _
-           (get-string-all (current-input-port))))))))
+(test-group "substitute*"
+  (define-syntax-rule (define-substitute*-test test-type name expected
+                        content clauses ...)
+    (test-type
+     name
+     expected
+     (with-fluids ((%default-port-encoding "UTF-8")
+                   (%default-port-conversion-strategy 'error))
+       ;; The GNU libc is locale sensitive.  Depending on the value of LANG,
+       ;; the test could fail with "string contains #\\nul character: ~S" or
+       ;; "cannot convert wide string to output locale".
+       (setlocale LC_ALL "en_US.UTF-8")
+       (call-with-temporary-output-file
+        (lambda (file port)
+          (format port content)
+          (flush-output-port port)
+
+          (substitute* file
+            clauses ...)
+
+          (with-input-from-file file
+            (lambda _
+              (get-string-all (current-input-port)))))))))
+
+  (define-substitute*-test test-equal
+    "substitute*, text contains a NUL byte, UTF-8"
+    "c\0d"                              ;expected
+    "a\0b"                              ;content
+    (("a") "c")
+    (("b") "d"))
+
+  (define-substitute*-test test-error "substitute*, no match error"
+    #t                                  ;expected
+    "a\0b"                              ;content
+    (("Oops!") "c"))
+
+  (define-substitute*-test test-error "substitute*, partial no match error"
+    #t                                  ;expected
+    "a\0b"                              ;content
+    (("a") "c"
+     ("Oops!") "c")))
 
 (test-equal "search-input-file: exception if not found"
   `((path)
-- 
2.41.0