www

commit bb376d39426c4ca7c16ec39e9c1ea4b7205a6b8e
parent c066a33ee9c81ac667e98531ebd705b39a12dba6
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Tue, 31 Jan 2017 06:09:25 +0100

A few small changes, exported make-auto-pvar needed by stxparse-info to have some auto-syntax-e-like behaviour

Diffstat:
M
main.rkt
 | 
50
+++++++++++++++++++++++++++++++++++++-------------
A
test/test-meta.rkt
 | 
27
+++++++++++++++++++++++++++
A
utils.rkt
 | 
4
++++

3 files changed, 68 insertions(+), 13 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -14,13 +14,18 @@
 (provide auto-with-syntax)
 (provide auto-syntax)
 (provide auto-syntax-case)
+(module+ utils
+  (provide (for-syntax make-auto-pvar
+                       auto-pvar?)))
 
 (define (leaves->datum e depth)
-  (if (> depth 0)
-      (map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e)
-      (if (syntax? e)
-          (syntax->datum e)
-          e)))
+  (if (eq? e #f) ;; for attributes with ~optional holes.
+      e
+      (if (> depth 0)
+          (map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e)
+          (if (syntax? e)
+              (syntax->datum e)
+              e))))
         
 
 (define-syntax (to-datum stx)
@@ -36,8 +41,27 @@
              #`(leaves->datum #,valvar #,depth))))]))
 
 (begin-for-syntax
+  (define (auto-pvar-proc self stx)
+    (cond
+      [(identifier? stx)
+       (datum->syntax stx
+                      `(,(quote-syntax to-datum) ,stx)
+                      stx
+                      stx)]
+      [(and (pair? (syntax-e stx))
+            (identifier? (car (syntax-e stx))))
+       (datum->syntax stx
+                      `((,(quote-syntax to-datum) ,(car (syntax-e stx)))
+                        .
+                        ,(cdr (syntax-e stx)))
+                      stx
+                      stx)]
+      [else (raise-syntax-error
+             'auto-syntax-e
+             "Improper use of auto-syntax-e pattern variable"
+             stx)]))
   (define-values (struct:auto-pvar
-                  make-auto-pvar
+                  -make-auto-pvar
                   auto-pvar?
                   auto-pvar-ref
                   auto-pvar-set!)
@@ -49,8 +73,9 @@
                       #f
                       null
                       (current-inspector)
-                      (λ (self stx)
-                        #`(to-datum #,stx)))))
+                      auto-pvar-proc))
+  (define (make-auto-pvar depth valvar)
+    (make-set!-transformer (-make-auto-pvar depth valvar))))
 
 (define-for-syntax (syntax->tree/ids e)
   (cond [(identifier? e) e]
@@ -76,11 +101,10 @@
       (let ()
         (record-disappeared-uses (syntax->list #'(pvar-id ...)))
         #'(let-syntax ([pvar-id
-                        (make-set!-transformer
-                         (let ([mapping (syntax-local-value
-                                         (quote-syntax pvar-id))])
-                           (make-auto-pvar (syntax-mapping-depth mapping)
-                                           (syntax-mapping-valvar mapping))))]
+                        (let ([mapping (syntax-local-value
+                                        (quote-syntax pvar-id))])
+                          (make-auto-pvar (syntax-mapping-depth mapping)
+                                          (syntax-mapping-valvar mapping)))]
                        ...)
             body ...)))]))
 
diff --git a/test/test-meta.rkt b/test/test-meta.rkt
@@ -0,0 +1,26 @@
+#lang racket
+(require auto-syntax-e (for-syntax racket/base))
+(auto-syntax-case #'(1 2 3) ()
+  [(x ...)
+   (map add1 x)])
+
+(begin-for-syntax
+  (require auto-syntax-e (for-syntax racket/base))
+  (auto-syntax-case #'(1 2 3) ()
+    [(x ...)
+     (map add1 x)]))
+
+(begin-for-syntax
+  (begin-for-syntax
+    (require auto-syntax-e (for-syntax racket/base))
+    (auto-syntax-case #'(1 2 3) ()
+      [(x ...)
+       (map add1 x)])))
+
+(begin-for-syntax
+  (begin-for-syntax
+    (begin-for-syntax
+      (require auto-syntax-e (for-syntax racket/base))
+      (auto-syntax-case #'(1 2 3) ()
+        [(x ...)
+         (map add1 x)]))))
+\ No newline at end of file
diff --git a/utils.rkt b/utils.rkt
@@ -0,0 +1,3 @@
+#lang racket
+(require (for-template (submod auto-syntax-e utils)))
+(provide (for-template (all-from-out (submod auto-syntax-e utils))))
+\ No newline at end of file