www

commit 99ca3ede0d94ce6bce6dd618116f840c8d35d5e8
parent c7fd8ed5503d7c3f2a2745be3687dee105673282
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Mon,  5 Sep 2016 02:16:53 +0200

Allow curried function definitions in (define/syntax-parse+simple ((id-or-curry curry-args) stx-args) …)

Diffstat:
M
private/define-syntax+simple-api.rkt
 | 
42
+++++++++++++++++++++++++-----------------

1 file changed, 25 insertions(+), 17 deletions(-)
diff --git a/private/define-syntax+simple-api.rkt b/private/define-syntax+simple-api.rkt
@@ -9,24 +9,15 @@
                      syntax/parse
                      racket/stxparam
                      racket/syntax
-                     phc-toolkit/untyped)
+                     phc-toolkit/untyped
+                     "parameters.rkt")
          (for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct))
          (for-meta 2 racket/base)
-         (for-meta 2 syntax/parse)
+         (for-meta 2 racket/list)
          (for-meta 2 racket/syntax)
+         (for-meta 2 syntax/parse)
          (for-meta 2 phc-toolkit/untyped))
 
-#;(define-syntax/case (define-syntax/parse+simple [name . args] . body) ()
-  (with-format-ids/inject-binders
-   ([name-forward #'name "~a-forward-attributes" #'name]
-    [tmp-forward  #'tmp  "~a-forward-attributes" #'tmp])
-   #'(begin
-       (begin-for-syntax
-         (inject-sub-range-binders ...
-          (define/syntax-parse+simple [tmp . args] . body)
-          (define-syntax name-forward (make-rename-transformer #'tmp-forward))))
-       (define-syntax name tmp))))
-
 (define-syntax/parse (define-syntax/parse+simple (~optional (~and two #:2))
                        [name . args] . body)
   (with-format-ids/inject-binders
@@ -55,17 +46,30 @@
                (pattern args))
              (define/syntax-parse+simple/stxclass [name args-stxclass]
                . body-introduced)))]))
+
+  (define-for-syntax (change-name-or-curry stx new-name)
+    (if (identifier? stx)
+        new-name
+        #`(#,(change-name-or-curry (stx-car stx) new-name) . #,(stx-cdr stx))))
+
+  #;(define-for-syntax (pat-name-or-curry stx new-name)
+      (if (identifier? stx)
+          new-name
+          #`(#,(pat-name-or-curry (stx-car stx) new-name) . #,(gensym 'args))))
   
   (define-syntax define/syntax-parse+simple/stxclass
     (syntax-parser
-      [(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))]
+      [(_ [name:name-or-curry
+           (~var cls (static syntax/parse:stxclass? "a syntax class"))]
           . body)
        #:with colon-stxclass (format-id #'cls ":~a" #'cls)
        (with-arrows
         (define/with-syntax name-forward
-          (format-id/record #'name "~a-forward-attributes" #'name))
+          (format-id/record #'name.id "~a-forward-attributes" #'name.id))
         (define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
-        (define attrs (syntax/parse:stxclass-attrs c))
+        (define attrs (filter-not (λ (a) (is-clause-id-sym?
+                                          (syntax/parse:attr-name a)))
+                                  (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)))
@@ -73,12 +77,15 @@
         (define-temp-ids "~a/arg" (attr-name …))
         (define/with-syntax (attr-depth …)
           (map syntax/parse:attr-depth attrs))
+        (define/with-syntax def-private-simple-api
+          (change-name-or-curry #'name
+                                #'(private-simple-api stx/arg attr-name/arg …)))
         #'(begin
             (define (name stx2)
               (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
                 (syntax-parse stx2
                   [(_ . colon-stxclass) . body])))
-            (define (private-simple-api stx/arg attr-name/arg …)
+            (define def-private-simple-api
               (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
                 (syntax-parse #'nothing
                   [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
@@ -91,6 +98,7 @@
                     (attribute #,(datum->syntax stx3 'attr-name))
                     …)]
                 [(_ forward-args-prefix)
+                 (identifier? #'forward-args-prefix)
                  #`(private-simple-api
                     stx
                     (attribute #,(format-id stx3 "~a.~a"