www

commit 4be72744a44ac9436544aea6c3f0b7bf61d9cf72
parent e7e60b1da9696abc6eb9a4de4614cdc346e1f5dd
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Fri,  3 Feb 2017 12:25:02 +0100

Tests for ?operations

Diffstat:
M
ddd.rkt
 | 
8
++++----
A
test/test-or-syntax.rkt
 | 
113
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
test/test-or.rkt
 | 
89
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------
M
unsyntax-preparse.rkt
 | 
5
++++-

4 files changed, 195 insertions(+), 20 deletions(-)
diff --git a/ddd.rkt b/ddd.rkt
@@ -135,7 +135,7 @@
 #;(define-syntax-rule (?@ v ...)
     (splicing-list (list v ...)))
 (define (?@ . vs) (splicing-list vs))
-(define (?@@ . vs) (map splicing-list vs))
+(define (?@@ . vs) (splicing-list (map splicing-list vs)))
 
 (define-for-syntax ((?* mode) stx)
   (define (parse stx)
@@ -173,14 +173,14 @@
   (syntax-case stx (else)
     [(self) #'(raise-syntax-error '?cond
                                   "all branches contain omitted elements"
-                                  self)]
+                                  (quote-syntax self))]
     [(self [else]) #'(?@)]
     [(self [else . v]) #'(begin . v)]
     [(self [condition v . vs] . rest)
      (not (free-identifier=? #'condition #'else))
-     (let ([else (datum->syntax stx `(,#'self . ,#'rest) stx stx)])
+     (let ([otherwise (datum->syntax stx `(,#'self . ,#'rest) stx stx)])
        (datum->syntax stx
-                      `(,#'?if ,#'condition ,#'(begin v . vs) . ,else)
+                      `(,#'?if ,#'condition ,#'(begin v . vs) ,otherwise)
                       stx
                       stx))]))
 
diff --git a/test/test-or-syntax.rkt b/test/test-or-syntax.rkt
@@ -0,0 +1,113 @@
+#lang racket
+
+(require subtemplate/ddd
+         subtemplate/unsyntax-preparse
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit
+         syntax/macro-testing
+         (only-in racket/base [... …]))
+
+;; ??
+
+(define (test-??-all v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean}
+       {~optional d:keyword})
+      (quasitemplate-ddd (?? a b c d))])))
+
+(check-equal? (test-??-all #'(1 x #f #:kw)) '1)
+(check-equal? (test-??-all #'(x #f #:kw)) 'x)
+(check-equal? (test-??-all #'(#f #:kw)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+(check-equal? (test-??-all #'(1)) '1)
+(check-equal? (test-??-all #'(x)) 'x)
+(check-equal? (test-??-all #'(#f)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+;; ?cond
+
+(define (test-?cond v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean}
+       {~optional d:keyword})
+      (quasitemplate-ddd (?cond [a 10] [b 20] [c 30] [d 40]))])))
+
+(check-equal? (test-?cond #'(1 x #f #:kw)) 10)
+(check-equal? (test-?cond #'(x #f #:kw)) 20)
+(check-equal? (test-?cond #'(#f #:kw)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
+
+(check-equal? (test-?cond #'(1)) 10)
+(check-equal? (test-?cond #'(x)) 20)
+(check-equal? (test-?cond #'(#f)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
+
+;; ?attr
+
+(define (test-?attr v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean}
+       {~optional d:keyword})
+      (quasitemplate-ddd ((?attr a) (?attr b) (?attr c) (?attr d)))])))
+
+(check-equal? (test-?attr #'(1 x #f #:kw)) '(#t #t #t #t))
+(check-equal? (test-?attr #'(x #f #:kw))   '(#f #t #t #t))
+(check-equal? (test-?attr #'(#f #:kw))     '(#f #f #t #t))
+(check-equal? (test-?attr #'(#:kw))        '(#f #f #f #t))
+
+(check-equal? (test-?attr #'(1))    '(#t #f #f #f))
+(check-equal? (test-?attr #'(x))    '(#f #t #f #f))
+(check-equal? (test-?attr #'(#f))   '(#f #f #t #f))
+(check-equal? (test-?attr #'(#:kw)) '(#f #f #f #t))
+
+;; ?if
+
+(define (test-?if v)
+  (syntax->datum
+   (syntax-parse v
+     [({~optional a:nat}
+       {~optional b:id}
+       {~optional c:boolean})
+      (quasitemplate-ddd (?if a b c))])))
+
+(check-equal? (test-?if #'(1 x #f)) 'x)
+(check-equal? (test-?if #'(x #f))   '#f)
+(check-equal? (test-?if #'(#f))     '#f)
+(check-exn #rx"attribute contains non-syntax value"
+           (λ ()
+             (convert-compile-time-error
+              (check-equal? (test-?if #'(1 #f)) '#f))))
+
+(check-equal? (syntax->datum
+               (syntax-parse #'(1 x)
+                 [({~optional a:nat}
+                   {~optional b:id}
+                   {~optional c:boolean}
+                   {~optional d:keyword})
+                  (quasitemplate-ddd (?if a (?if b a d) 0))]))
+              1)
+
+;; ?@@
+
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (x y) (#f))
+                 [(a b c)
+                  (quasitemplate-ddd ({?@@ a b c}))]))
+              '(1 2 3 x y #f))
+
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (x y) (#f))
+                 [whole
+                  (quasitemplate-ddd ({?@@ . whole}))]))
+              '(1 2 3 x y #f))
diff --git a/test/test-or.rkt b/test/test-or.rkt
@@ -1,19 +1,23 @@
 #lang racket
 
 (require subtemplate/ddd
+         subtemplate/ddd-forms
          subtemplate/unsyntax-preparse
          stxparse-info/case
          stxparse-info/parse
-         rackunit)
+         rackunit
+         syntax/macro-testing
+         (only-in racket/base [... …]))
+
+;; ??
 
 (define (test-??-all v)
-  (syntax->datum
-   (syntax-parse v
-     [({~optional a:nat}
-       {~optional b:id}
-       {~optional c:boolean}
-       {~optional d:keyword})
-      (quasitemplate-ddd (?? a b c d))])))
+  (syntax-parse v
+    [({~optional a:nat}
+      {~optional b:id}
+      {~optional c:boolean}
+      {~optional d:keyword})
+     (?? a b c d)]))
 
 (check-equal? (test-??-all #'(1 x #f #:kw)) '1)
 (check-equal? (test-??-all #'(x #f #:kw)) 'x)
@@ -25,14 +29,15 @@
 (check-equal? (test-??-all #'(#f)) '#f)
 (check-equal? (test-??-all #'(#:kw)) '#:kw)
 
+;; ?cond
+
 (define (test-?cond v)
-  (syntax->datum
-   (syntax-parse v
-     [({~optional a:nat}
-       {~optional b:id}
-       {~optional c:boolean}
-       {~optional d:keyword})
-      (quasitemplate-ddd (?cond [a 10] [b 20] [c 30] [d 40]))])))
+  (syntax-parse v
+    [({~optional a:nat}
+      {~optional b:id}
+      {~optional c:boolean}
+      {~optional d:keyword})
+     (?cond [a 10] [b 20] [c 30] [d 40])]))
 
 (check-equal? (test-?cond #'(1 x #f #:kw)) 10)
 (check-equal? (test-?cond #'(x #f #:kw)) 20)
@@ -43,3 +48,57 @@
 (check-equal? (test-?cond #'(x)) 20)
 (check-equal? (test-?cond #'(#f)) 30)
 (check-equal? (test-?cond #'(#:kw)) 40)
+
+;; ?attr
+
+(define (test-?attr v)
+  (syntax-parse v
+    [({~optional a:nat}
+      {~optional b:id}
+      {~optional c:boolean}
+      {~optional d:keyword})
+     (list (?attr a) (?attr b) (?attr c) (?attr d))]))
+
+(check-equal? (test-?attr #'(1 x #f #:kw)) '(#t #t #t #t))
+(check-equal? (test-?attr #'(x #f #:kw))   '(#f #t #t #t))
+(check-equal? (test-?attr #'(#f #:kw))     '(#f #f #t #t))
+(check-equal? (test-?attr #'(#:kw))        '(#f #f #f #t))
+
+(check-equal? (test-?attr #'(1))    '(#t #f #f #f))
+(check-equal? (test-?attr #'(x))    '(#f #t #f #f))
+(check-equal? (test-?attr #'(#f))   '(#f #f #t #f))
+(check-equal? (test-?attr #'(#:kw)) '(#f #f #f #t))
+
+;; ?if
+
+(define (test-?if v)
+  (syntax-parse v
+    [({~optional a:nat}
+      {~optional b:id}
+      {~optional c:keyword})
+     (?if a b c)]))
+
+(check-equal? (test-?if #'(1 x #:kw)) 'x)
+(check-equal? (test-?if #'(x #:kw))   '#:kw)
+(check-equal? (test-?if #'(#:kw))     '#:kw)
+(check-equal? (test-?if #'(1 #:kw))   '#f)
+
+(check-equal? (syntax-parse #'(1 x)
+                [({~optional a:nat}
+                  {~optional b:id}
+                  {~optional c:boolean}
+                  {~optional d:keyword})
+                 (?if a (?if b a d) 0)])
+              1)
+
+;; ?@@
+
+(check-equal? (syntax-parse #'((1 2 3) (x y) (#f))
+                [(a b c)
+                 (vector {?@@ a b c})])
+              #(1 2 3 x y #f))
+
+(check-equal? (syntax-parse #'((1 2 3) (x y) (#f))
+                [whole
+                 (vector {?@@ . whole})])
+              #(1 2 3 x y #f))
diff --git a/unsyntax-preparse.rkt b/unsyntax-preparse.rkt
@@ -12,6 +12,7 @@
          stxparse-info/parse
          stxparse-info/case
          syntax/stx
+         racket/list
          (for-syntax racket/base
                      racket/list
                      racket/syntax
@@ -146,7 +147,9 @@
                                      `(,form (,new-tmpl) . ,#'opts)
                                      stx
                                      stx))
-                  (check-single-result result (quote-syntax stx) 'form)))))))]))
+                  (check-single-result result
+                                       (quote-syntax #,stx)
+                                       'form)))))))]))
 
 (define-syntax quasitemplate-ddd (*template-ddd #t #'quasitemplate))
 (define-syntax quasisubtemplate-ddd (*template-ddd #t #'quasisubtemplate))