diff mbox series

[bug#51922,1/2] guix: Add syntax to capture arguments' syntax-properties.

Message ID 20211117144348.17090-1-dev@jpoiret.xyz
State Accepted
Headers show
Series Improve the reported location of configuration warnings | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git branch success View Git branch
cbaines/applying patch success View Laminar job
cbaines/issue success View issue

Commit Message

Josselin Poiret Nov. 17, 2021, 2:43 p.m. UTC 
* guix/diagnostics.scm (define-with-syntax-properties): Add it.
---
 guix/diagnostics.scm | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)
diff mbox series

Patch

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 6a792febd4..337a73c1a2 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -54,7 +54,9 @@  (define-module (guix diagnostics)
             condition-fix-hint
 
             guix-warning-port
-            program-name))
+            program-name
+
+            define-with-syntax-properties))
 
 ;;; Commentary:
 ;;;
@@ -331,3 +333,37 @@  (define guix-warning-port
 (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)))))