10/13: diagnostics: Add syntax to capture arguments' syntax-properties.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 346d2f64889b0c82111e790e999bf6c754027e04
Author: Josselin Poiret <dev@jpoiret.xyz>
AuthorDate: Wed Nov 17 14:43:47 2021 +0000

    diagnostics: Add syntax to capture arguments' syntax-properties.
    
    * guix/diagnostics.scm (define-with-syntax-properties): Add it.
    
    Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/diagnostics.scm | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 6a792fe..337a73c 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -54,7 +54,9 @@
             condition-fix-hint
 
             guix-warning-port
-            program-name))
+            program-name
+
+            define-with-syntax-properties))
 
 ;;; Commentary:
 ;;;
@@ -331,3 +333,37 @@ number of arguments in ARGS matches the escapes in FORMAT."
 (define program-name
   ;; Name of the command-line program currently executing, or #f.
   (make-parameter #f))
+
+
+(define-syntax define-with-syntax-properties
+  (lambda (x)
+    "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and
+SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties,
+respectively, of each ensuing syntax object."
+    (syntax-case x ()
+      ((_ (binding (value-identifier syntax-properties-identifier)
+                   ...)
+          body ...)
+       (and (and-map identifier? #'(value-identifier ...))
+            (and-map identifier? #'(syntax-properties-identifier ...)))
+       #'(define-syntax binding
+           (lambda (y)
+             (with-ellipsis :::
+               (syntax-case y ()
+                 ((_ value-identifier ...)
+                  (with-syntax ((syntax-properties-identifier
+                                 #`'#,(datum->syntax y
+                                                     (syntax-source
+                                                      #'value-identifier)))
+                                ...)
+                    #'(begin body ...)))
+                 (_
+                  (syntax-violation #f (format #f
+                                               "Expected (~a~{ ~a~})"
+                                               'binding
+                                               '(value-identifier ...))
+                                    y)))))))
+      (_
+       (syntax-violation #f "Expected a definition of the form \
+(define-with-syntax-properties (binding (value syntax-properties) \
+...) body ...)" x)))))