www

commit 984f861a85d7773677c5c7fdd6d6e43e796bbc5f
parent abe7438d7dd3bd77e61dd39d8c375f17308c9367
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Thu,  7 Apr 2016 18:56:06 +0200

Wrote a preexpander for a simplified variant of syntax-case.

Diffstat:
A
and.rkt
 | 
18
++++++++++++++++++
A
syntax-case.rkt
 | 
66
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
test/test-syntax-case.rkt
 | 
30
++++++++++++++++++++++++++++++

3 files changed, 114 insertions(+), 0 deletions(-)
diff --git a/and.rkt b/and.rkt
@@ -0,0 +1,17 @@
+#lang racket
+
+(provide preexpanded-and)
+
+(require syntax/parse
+         (for-template racket/base))
+
+(define (preexpanded-and stx)
+  (syntax-parse stx
+    [(clause)
+     #'clause]
+    [(#t . rest)
+     (preexpanded-and #`rest)]
+    [(clause . rest)
+     #`(if clause
+           #,(preexpanded-and #`rest)
+           #f)]))
+\ No newline at end of file
diff --git a/syntax-case.rkt b/syntax-case.rkt
@@ -0,0 +1,65 @@
+#lang racket
+
+(provide preexpanded-syntax-case/no-bind)
+
+(require (for-syntax preexpanded/and
+                     racket/pretty
+                     syntax/stx
+                     syntax/parse
+                     syntax/parse/experimental/template)
+         syntax/stx)
+
+(begin-for-syntax
+  (define-syntax-class (pat part)
+    #:attributes (test)
+    (pattern (~literal _)
+             #:with test #'#t)
+    (pattern ()
+             #:with test #`(null? #,part))
+    (pattern ((~literal ~literal) identifier:id)
+             #:when (syntax-pattern-variable?
+                     (syntax-local-value #'identifier
+                                         (λ _ #f)))
+             #:with test #`(free-identifier=? #,part (quote-syntax identifier)))
+    (pattern ((~literal ~literal) identifier:id)
+             #:with test #`(free-identifier=? #,part (quote-syntax identifier)))
+    (pattern ((~literal ~datum) identifier:id)
+             #:with test #`(eq? (syntax-e #,part) 'identifier))
+    (pattern k:keyword
+             #:with test #`(eq? (syntax-e #,part) 'k))
+    (pattern ((~var sub (pat #'car-part)) . (~var rest (pat #'cdr-part)))
+             ;; TODO: optimize the #t case.
+             #:with test (preexpanded-and
+                          #`((stx-pair? #,part)
+                             (let-values ([(car-part) (stx-car #,part)]
+                                          [(cdr-part) (stx-cdr #,part)])
+                               #,(preexpanded-and
+                                  #'(sub.test rest.test))))))))
+
+
+(begin-for-syntax
+  (define-splicing-syntax-class (clause-maybe-dotted whole)
+    (pattern (~seq [(~var pat (pat whole)) body]
+                   (~optional (~seq (patvar ...)
+                                    (~and ddd (~literal ...)))))
+             #:with test #'pat.test
+             ;#:with (patvar ...) #`#,(attribute pat.patvar)
+             #:with expanded
+             (if (attribute ddd)
+                 #'(map (lambda (patvar ...)
+                          (with-syntax ([patvar patvar] ...)
+                            #'[test body]))
+                        (syntax->list #'(patvar (... ...)))
+                        ...)
+                 #'(list #'[test body])))))
+
+(define-syntax (preexpanded-syntax-case/no-bind stx)
+  (syntax-parse stx
+    [(_ name stx2 (~var clause (clause-maybe-dotted #'whole)) ...)
+     ((λ (x)
+        ;(pretty-write (syntax->datum x))
+        x)
+      #'#`(let-values ([(whole) stx2])
+            (cond #,@clause.expanded
+                  ...
+                  [else (raise-syntax-error 'name "Invalid syntax" whole)])))]))
+\ No newline at end of file
diff --git a/test/test-syntax-case.rkt b/test/test-syntax-case.rkt
@@ -0,0 +1,30 @@
+#lang racket
+
+(require (for-syntax preexpanded/syntax-case))
+
+(define-syntax (define-a*-b stx)
+  (syntax-case stx ()
+    [(_ name [foo val] ...)
+     #`(define-syntax (name stx2)
+         #,(preexpanded-syntax-case/no-bind define-a*-b stx2
+             [(_ #:a (~literal foo)) #'val]
+             (foo val)
+             ...
+             [(_ #:b) #'2]))]))
+
+(define-a*-b myab [a 10] [b 20] [c 30])
+(myab #:a a)
+(myab #:a b)
+(myab #:a c)
+;(myab #:a d)   ;; Invalid syntax, as expected
+;(myab #:a)     ;; Invalid syntax, as expected
+;(myab #:a a e) ;; Invalid syntax, as expected
+(myab #:b)
+
+#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:a +)
+    [(_ #:a (~literal +)) 1]
+    [(_ #:b) 2])
+
+#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:b foo)
+    [(_ #:a (~literal +)) 1]
+    [(_ #:b (~datum foo)) 2])