www

commit 6475b89bc87167b21d3466bc0a01cd83d6133a36
parent f5078752aa084c26e3e2ad35893a1a0f481a6d30
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Mon, 29 Aug 2016 21:27:14 +0200

Added define-syntax/parse+simple and define/syntax-parse+simple

Diffstat:
M
main.rkt
 | 
8
+++++---
A
private/define-syntax+simple-api.rkt
 | 
68
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
test/test-extend-structure-options.rkt
 | 
25
+++++++++++++++++++++++++
M
test/test-structure-options.rkt
 | 
3
++-

4 files changed, 100 insertions(+), 4 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -5,7 +5,8 @@
          "private/no-order.rkt"
          "private/post.rkt"
          "private/global.rkt"
-         "private/optional.rkt")
+         "private/optional.rkt"
+         (for-template "private/define-syntax+simple-api.rkt"))
 
 (provide #;define-splicing-syntax-class-with-eh-mixins
          #;define-syntax-class-with-eh-mixins
@@ -22,5 +23,6 @@
          ~global-counter
          aggregate-global-or
          aggregate-global-and
-         aggregate-global-counter)
-
+         aggregate-global-counter
+         (for-template define-syntax/parse+simple)
+         define/syntax-parse+simple)
diff --git a/private/define-syntax+simple-api.rkt b/private/define-syntax+simple-api.rkt
@@ -0,0 +1,67 @@
+#lang racket/base
+
+(provide define-syntax/parse+simple
+         (for-syntax define/syntax-parse+simple))
+
+(require phc-toolkit/untyped
+         syntax/parse/define
+         (for-syntax racket/base
+                     syntax/parse
+                     racket/stxparam
+                     racket/syntax)
+         (for-meta 2
+                   racket/base
+                   syntax/parse
+                   racket/syntax
+                   phc-toolkit/untyped
+                   (prefix-in syntax/parse: syntax/parse/private/residual-ct)))
+
+(define-simple-macro (define-syntax/parse+simple [name stxclass] . body)
+  #:with name-forward (format-id #'name "~a-forward-attributes" #'name)
+  #:with tmp-forward (format-id #'tmp "~a-forward-attributes" #'tmp)
+  (begin
+    (begin-for-syntax
+      (define/syntax-parse+simple [tmp stxclass] . body)
+      (define-syntax name-forward (make-rename-transformer #'tmp-forward)))
+    (define-syntax name tmp)))
+
+(begin-for-syntax
+  (define-syntax define/syntax-parse+simple
+    (syntax-parser
+      [(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))]
+          . body)
+       #:with colon-stxclass (format-id #'cls ":~a" #'cls)
+       #:with name-forward (format-id #'name "~a-forward-attributes" #'name)
+       (with-disappeared-uses
+        (define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
+        (define attrs (syntax/parse:stxclass-attrs c))
+        (define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs))
+        (define/with-syntax (attr-name/ctx …)
+          (stx-map (λ (a) (datum->syntax #'body (syntax-e a)))
+                   #'(attr-name …)))
+        (define-temp-ids "~a/arg" (attr-name …))
+        (define/with-syntax (attr-depth …) (map syntax/parse:attr-depth attrs))
+        #'(begin
+            (define (name stx2)
+              (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
+                (syntax-parse stx2
+                  [(name colon-stxclass) . body])))
+            (define (private-simple-api stx/arg attr-name/arg …)
+              (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
+                (syntax-parse #'nothing
+                  [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
+                   . body])))
+            (define-syntax (name-forward stx3)
+              (syntax-case stx3 ()
+                [(_)
+                 #`(private-simple-api
+                    stx
+                    (attribute #,(datum->syntax stx3 'attr-name))
+                    …)]
+                [(_ forward-args-prefix)
+                 #`(private-simple-api
+                    stx
+                    (attribute #,(format-id stx3 "~a.~a"
+                                            #'forward-args-prefix
+                                            'attr-name))
+                    …)]))))])))
+\ No newline at end of file
diff --git a/test/test-extend-structure-options.rkt b/test/test-extend-structure-options.rkt
@@ -0,0 +1,25 @@
+#lang racket
+
+(require rackunit
+         phc-toolkit/untyped
+         (for-syntax extensible-parser-specifications
+                     "test-structure-options.rkt"
+                     syntax/parse))
+
+(define-syntax/parse+simple [foo structure-kws]
+  #''(field ...))
+
+(check-equal? (foo [f tf] [g tg])
+              '(f g))
+
+(begin-for-syntax
+  (define-splicing-syntax-class structure-xyz-kws
+    (pattern {~seq-no-order {~optional {~seq #:xyz xyz:id}}
+                            {structure-kw-all-mixin}})))
+
+(define-syntax/parse [bar :structure-xyz-kws]
+  #`'[(xyz field ...)
+      #,(foo-forward-attributes)])
+
+(check-equal? (bar #:xyz zyx [f tf] [g tg])
+              '((zyx f g) (quote (f g))))
diff --git a/test/test-structure-options.rkt b/test/test-structure-options.rkt
@@ -14,7 +14,8 @@
 (provide structure-kw-instance-or-builder-mixin
          structure-kw-predicate-mixin
          structure-kw-fields-mixin
-         structure-kw-all-mixin)
+         structure-kw-all-mixin
+         structure-kws)
 
 (define-eh-alternative-mixin structure-kw-instance-or-builder-mixin
   (pattern