suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Tests for ?operations

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-03 12:25:02 +01:00
parent e7e60b1da9
commit 4be72744a4
4 changed files with 195 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
ddd.rkt
View File

@ -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))]))

113
test/test-or-syntax.rkt Normal file
View File

@ -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))

89
test/test-or.rkt
View File

@ -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))

5
unsyntax-preparse.rkt
View File

@ -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))