commit 81a05e6ff356068b184912a7a7d27010e2ee3891
parent 82547e2960af655a31e1f6502c3b5298bf26cd1b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 26 Jan 2017 21:04:52 +0100
Improved coverage
Diffstat:
2 files changed, 467 insertions(+), 150 deletions(-)
diff --git a/README.md b/README.md
@@ -1,3 +1,9 @@
+[](https://travis-ci.org/jsmaniac/stxparse-info)
+[](https://codecov.io/gh/jsmaniac/stxparse-info)
+[](http://jsmaniac.github.io/travis-stats/#jsmaniac/stxparse-info)
+[](http://docs.racket-lang.org/stxparse-info/)
+
+
stxparse-info
=============
diff --git a/test/test-current-pvars.rkt b/test/test-current-pvars.rkt
@@ -3,12 +3,21 @@
stxparse-info/case
stxparse-info/current-pvars
racket/stxparam
- rackunit)
+ rackunit
+ syntax/macro-testing
+ (for-syntax racket/list))
;; Test utilities
(define-syntax (list-pvars stx)
#`'#,(current-pvars))
+(define-syntax (list-pvars+unique-id stx)
+ #`'#,(current-pvars+unique))
+
+(define-syntax (list-pvars+unique-val stx)
+ (with-syntax ([([pv . un] ...) (current-pvars+unique)])
+ #`(list (cons 'pv un) ...)))
+
;; Check that the identifier has the right scopes
(define-syntax (ref-nth-pvar stx)
(syntax-case stx ()
@@ -85,6 +94,11 @@
'())
(check-equal? (syntax-case #'(1 (2 3) a b c) ()
+ [(_ ...)
+ (list-pvars)])
+ '())
+
+ (check-equal? (syntax-case #'(1 (2 3) a b c) ()
[(x (y ...) z ...)
(list-pvars)])
'(z y x))
@@ -92,6 +106,16 @@
(check-equal? (list-pvars)
'())
+ (check-equal? (syntax-case #'(x) ()
+ [(_)
+ (list-pvars)])
+ '())
+
+ (check-equal? (syntax-case #'() ()
+ [()
+ (list-pvars)])
+ '())
+
(check-equal? (syntax-parse #'1
[x
(syntax->datum (ref-nth-pvar 0))])
@@ -108,159 +132,446 @@
;; tests for define/syntax-parse and define/syntax-case
(define-syntax-rule (gen-test-define define/xxx)
- (begin
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx z #'3)
- (list-pvars)])
- '(z y x))
-
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx z #'3)
- (list (syntax->datum (ref-nth-pvar 0))
- (syntax->datum (ref-nth-pvar 1))
- (syntax->datum (ref-nth-pvar 2)))])
- '(3 2 1))
-
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx x #'3)
- (list-pvars)])
- '(x y x))
-
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx x #'3)
- (list (syntax->datum (ref-nth-pvar 0))
- (syntax->datum (ref-nth-pvar 1))
- (syntax->datum (ref-nth-pvar 2)))])
- '(3 2 1))
-
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx x #'3)
- (define/xxx y #'4)
- (list (syntax->datum (ref-nth-pvar 0))
- (syntax->datum (ref-nth-pvar 1))
- (syntax->datum (ref-nth-pvar 2))
- (syntax->datum (ref-nth-pvar 3)))])
- '(4 3 2 1))
+ (...
+ (begin
+ (check-equal? (syntax-parse #'1
+ [_
+ (list (list-pvars)
+ (let ()
+ (define/xxx z #'3)
+ (list-pvars)))])
+ '(() (z)))
+
+ (check-equal? (syntax-parse #'1
+ [_
+ (syntax-parse #'2
+ [_
+ (list-pvars)])])
+ '())
+
+ (check-equal? (let ()
+ (define/xxx _ #'1)
+ (list-pvars))
+ '())
+
+ (check-equal? (let ()
+ (define/xxx (_ ...) #'(1 2 3))
+ (list-pvars))
+ '())
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx z #'3)
+ (list-pvars)])
+ '(z y x))
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx z #'3)
+ (list (syntax->datum (ref-nth-pvar 0))
+ (syntax->datum (ref-nth-pvar 1))
+ (syntax->datum (ref-nth-pvar 2)))])
+ '(3 2 1))
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx x #'3)
+ (list-pvars)])
+ '(x y x))
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with (y ...) #'(2 3)
+ (define/xxx (x ...) #'(4 5))
+ (list-pvars)])
+ '(x y x))
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx x #'3)
+ (list (syntax->datum (ref-nth-pvar 0))
+ (syntax->datum (ref-nth-pvar 1))
+ (syntax->datum (ref-nth-pvar 2)))])
+ '(3 2 1))
+
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx x #'3)
+ (define/xxx y #'4)
+ (list (syntax->datum (ref-nth-pvar 0))
+ (syntax->datum (ref-nth-pvar 1))
+ (syntax->datum (ref-nth-pvar 2))
+ (syntax->datum (ref-nth-pvar 3)))])
+ '(4 3 2 1))
- (check-equal? (syntax-parse #'1
- [x
- #:with y #'2
- (define/xxx x #'3)
- (define/xxx y #'4)
- (define/xxx z #'5)
- (list (syntax->datum (ref-nth-pvar 0))
- (syntax->datum (ref-nth-pvar 1))
- (syntax->datum (ref-nth-pvar 2))
- (syntax->datum (ref-nth-pvar 3))
- (syntax->datum (ref-nth-pvar 4)))])
- '(5 4 3 2 1))
-
- (check-equal? (syntax-parse #'(1 2 3)
- [(x y z)
- (define/xxx x #'4)
- (define/xxx y #'5)
- (list (syntax->datum (ref-nth-pvar 0))
- (syntax->datum (ref-nth-pvar 1))
- (syntax->datum (ref-nth-pvar 2))
- (syntax->datum (ref-nth-pvar 3))
- (syntax->datum (ref-nth-pvar 4)))])
- '(5 4 3 2 1))
-
- (check-equal? (syntax-parse #'(1 2 3)
- [(x y z)
- (define/xxx x #'4)
- (define/xxx y #'5)
- (list-pvars)])
- '(y x z y x))
-
- ;; Test with nested let, less variables in the nested let
- (check-equal? (let ()
- (define/xxx w #'1)
- (define/xxx x #'2)
- (define/xxx y #'3)
- (define/xxx z #'4)
- (list (list-pvars)
- (let ()
- (define/xxx w #'5)
- (define/xxx x #'6)
- (list-pvars))
- (list-pvars)))
- '((z y x w) (x w z y x w) (z y x w)))
-
- ;; Test with nested let, more variables in the nested let
- (check-equal? (let ()
- (define/xxx w #'1)
- (define/xxx x #'2)
- (list (list-pvars)
- (let ()
- (define/xxx w #'3)
- (define/xxx x #'4)
- (define/xxx y #'5)
- (define/xxx z #'6)
- (list-pvars))
- (list-pvars)))
- '((x w) (z y x w x w) (x w)))
-
- (check-equal? (let ()
- (define/xxx w #'1)
- (define/xxx x #'2)
- (define/xxx y #'3)
- (define/xxx z #'4)
- (list (list-pvars)
- (syntax-parse #'5
- [k
+ (check-equal? (syntax-parse #'1
+ [x
+ #:with y #'2
+ (define/xxx x #'3)
+ (define/xxx y #'4)
+ (define/xxx z #'5)
+ (list (syntax->datum (ref-nth-pvar 0))
+ (syntax->datum (ref-nth-pvar 1))
+ (syntax->datum (ref-nth-pvar 2))
+ (syntax->datum (ref-nth-pvar 3))
+ (syntax->datum (ref-nth-pvar 4)))])
+ '(5 4 3 2 1))
+
+ (check-equal? (syntax-parse #'(1 2 3)
+ [(x y z)
+ (define/xxx x #'4)
+ (define/xxx y #'5)
+ (list (syntax->datum (ref-nth-pvar 0))
+ (syntax->datum (ref-nth-pvar 1))
+ (syntax->datum (ref-nth-pvar 2))
+ (syntax->datum (ref-nth-pvar 3))
+ (syntax->datum (ref-nth-pvar 4)))])
+ '(5 4 3 2 1))
+
+ (check-equal? (syntax-parse #'(1 2 3)
+ [(x y z)
+ (define/xxx x #'4)
+ (define/xxx y #'5)
+ (list-pvars)])
+ '(y x z y x))
+
+ ;; Test with nested let, less variables in the nested let
+ (check-equal? (let ()
+ (define/xxx w #'1)
+ (define/xxx x #'2)
+ (define/xxx y #'3)
+ (define/xxx z #'4)
+ (list (list-pvars)
+ (let ()
(define/xxx w #'5)
(define/xxx x #'6)
- (list-pvars)])
- (list-pvars)))
- '((z y x w) (x w k z y x w) (z y x w)))
-
- (check-equal? (let ()
- (define/xxx w #'1)
- (define/xxx x #'2)
- (list (list-pvars)
- (syntax-parse #'5
- [k
- (define/xxx w #'3)
- (define/xxx x #'4)
- (define/xxx y #'5)
- (define/xxx z #'6)
- (list-pvars)])
- (list-pvars)))
- '((x w) (z y x w k x w) (x w)))
-
- (check-equal? (let ()
- (define/xxx w #'1)
- (define/xxx x #'2)
- (list (list-pvars)
- (syntax-parse #'5
- [k
+ (list-pvars))
+ (list-pvars)))
+ '((z y x w) (x w z y x w) (z y x w)))
+
+ ;; Test with nested let, more variables in the nested let
+ (check-equal? (let ()
+ (define/xxx w #'1)
+ (define/xxx x #'2)
+ (list (list-pvars)
+ (let ()
(define/xxx w #'3)
(define/xxx x #'4)
(define/xxx y #'5)
(define/xxx z #'6)
- (list (list-pvars)
- (syntax-parse #'5
- [k
- (define/xxx x #'4)
- (define/xxx y #'4)
- (list-pvars)])
- (list-pvars))])
- (list-pvars)))
- '((x w)
- ((z y x w k x w)
- (y x k z y x w k x w)
- (z y x w k x w))
- (x w)))))
+ (list-pvars))
+ (list-pvars)))
+ '((x w) (z y x w x w) (x w)))
+
+ (check-equal? (let ()
+ (define/xxx w #'1)
+ (define/xxx x #'2)
+ (define/xxx y #'3)
+ (define/xxx z #'4)
+ (list (list-pvars)
+ (syntax-parse #'5
+ [k
+ (define/xxx w #'5)
+ (define/xxx x #'6)
+ (list-pvars)])
+ (list-pvars)))
+ '((z y x w) (x w k z y x w) (z y x w)))
+
+ (check-equal? (let ()
+ (define/xxx w #'1)
+ (define/xxx x #'2)
+ (list (list-pvars)
+ (syntax-parse #'5
+ [k
+ (define/xxx w #'3)
+ (define/xxx x #'4)
+ (define/xxx y #'5)
+ (define/xxx z #'6)
+ (list-pvars)])
+ (list-pvars)))
+ '((x w) (z y x w k x w) (x w)))
+
+ (check-equal? (let ()
+ (define/xxx w #'1)
+ (define/xxx x #'2)
+ (list (list-pvars)
+ (syntax-parse #'5
+ [k
+ (define/xxx w #'3)
+ (define/xxx x #'4)
+ (define/xxx y #'5)
+ (define/xxx z #'6)
+ (list (list-pvars)
+ (syntax-parse #'5
+ [k
+ (define/xxx x #'4)
+ (define/xxx y #'4)
+ (list-pvars)])
+ (list-pvars))])
+ (list-pvars)))
+ '((x w)
+ ((z y x w k x w)
+ (y x k z y x w k x w)
+ (z y x w k x w))
+ (x w))))))
(gen-test-define define/syntax-parse)
-(gen-test-define define/with-syntax)
-\ No newline at end of file
+(gen-test-define define/with-syntax)
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (with-pvars a 'body))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (with-pvars ((a)) 'body))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (with-pvars ((a) b) 'body))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (with-pvars (a) 'body1 . 2))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (let ()
+ (define-pvars (a))))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (let ()
+ (define-pvars (a) b)))))
+
+(check-exn #rx"bad syntax"
+ (λ ()
+ (convert-compile-time-error
+ (let ()
+ (define-pvars a . 2)))))
+
+(check-true (match (syntax-case #'(1 2 3) ()
+ [(x ... y)
+ (list-pvars+unique-id)])
+ [(list (cons 'y (? symbol?))
+ (cons 'x (? symbol?)))
+ #true]
+ [_
+ #false]))
+
+(check-true (match (syntax-case #'(1 2 3) ()
+ [(x ... y)
+ (list-pvars+unique-val)])
+ [(list (cons 'y (? symbol?))
+ (cons 'x (? symbol?)))
+ #true]
+ [_
+ #false]))
+
+(check-equal? (match (map (λ (v)
+ (syntax-case v ()
+ [(x ... y)
+ (list-pvars+unique-id)])) ;; ID
+ (list #'(a b c) #'(d)))
+ [(list (list (cons 'y (? symbol? y-unique1))
+ (cons 'x (? symbol? x-unique1)))
+ (list (cons 'y (? symbol? y-unique2))
+ (cons 'x (? symbol? x-unique2))))
+ (list (eq? y-unique1 y-unique1)
+ (eq? y-unique1 x-unique1)
+ (eq? y-unique1 y-unique2)
+ (eq? y-unique1 x-unique2)
+
+ (eq? x-unique1 y-unique1)
+ (eq? x-unique1 x-unique1)
+ (eq? x-unique1 y-unique2)
+ (eq? x-unique1 x-unique2)
+
+ (eq? y-unique2 y-unique1)
+ (eq? y-unique2 x-unique1)
+ (eq? y-unique2 y-unique2)
+ (eq? y-unique2 x-unique2)
+
+ (eq? x-unique2 y-unique1)
+ (eq? x-unique2 x-unique1)
+ (eq? x-unique2 y-unique2)
+ (eq? x-unique2 x-unique2))]
+ [_
+ #false])
+ (list #t #f #t #f
+ #f #t #f #t
+ #t #f #t #f
+ #f #t #f #t))
+
+(check-equal? (match (map (λ (v)
+ (syntax-case v ()
+ [(x ... y)
+ (list-pvars+unique-val)])) ;; VAL
+ (list #'(a b c) #'(d)))
+ [(list (list (cons 'y (? symbol? y-unique1))
+ (cons 'x (? symbol? x-unique1)))
+ (list (cons 'y (? symbol? y-unique2))
+ (cons 'x (? symbol? x-unique2))))
+ (list (eq? y-unique1 y-unique1)
+ (eq? y-unique1 x-unique1)
+ (eq? y-unique1 y-unique2)
+ (eq? y-unique1 x-unique2)
+
+ (eq? x-unique1 y-unique1)
+ (eq? x-unique1 x-unique1)
+ (eq? x-unique1 y-unique2)
+ (eq? x-unique1 x-unique2)
+
+ (eq? y-unique2 y-unique1)
+ (eq? y-unique2 x-unique1)
+ (eq? y-unique2 y-unique2)
+ (eq? y-unique2 x-unique2)
+
+ (eq? x-unique2 y-unique1)
+ (eq? x-unique2 x-unique1)
+ (eq? x-unique2 y-unique2)
+ (eq? x-unique2 x-unique2))]
+ [_
+ #false])
+ (list #t #f #f #f
+ #f #t #f #f
+ #f #f #t #f
+ #f #f #f #t))
+
+(check-equal? (syntax-case #'(1 2 3) ()
+ [(_ ... _)
+ (list-pvars+unique-id)])
+ '())
+
+(check-equal? (syntax-case #'(1 2 3) ()
+ [(_ ... _)
+ (list-pvars+unique-val)])
+ '())
+
+;; stress-test the binary tree implementation
+(define-syntax-rule (defs1 pv ...)
+ (let ()
+ (define/with-syntax pv #'12321)
+ ...
+ (list-pvars)))
+
+(define-syntax (check-defs1 stx)
+ (syntax-case stx ()
+ [(_ n)
+ (with-syntax ([(pv ...) (map (λ (_) (gensym))
+ (range (syntax-e #'n)))])
+ #'(check-equal? (reverse (defs1 pv ...)) '(pv ...)))]))
+
+(define-syntax (check-defs1* stx)
+ (syntax-case stx ()
+ [(_ start end)
+ (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))])
+ #'(begin
+ (check-defs1 nᵢ)
+ ...))]))
+
+(check-equal? (reverse (defs1)) '())
+(check-equal? (reverse (defs1 a)) '(a))
+(check-equal? (reverse (defs1 a b)) '(a b))
+(check-equal? (reverse (defs1 a b c)) '(a b c))
+(check-equal? (reverse (defs1 a b c d)) '(a b c d))
+(check-equal? (reverse (defs1 a b c d e)) '(a b c d e))
+(check-defs1* 6 65) ;; continue tests with 6 till 65 pvars
+
+(define-syntax-rule (defs2 pv ...)
+ (let ()
+ (define/with-syntax xyz #'12300)
+ (define/with-syntax pv #'12321)
+ ...
+ (define/with-syntax www #'12399)
+ (let ()
+ (define/with-syntax pv #'12321)
+ ...
+ (list-pvars))))
+
+(define-syntax (check-defs2 stx)
+ (syntax-case stx ()
+ [(_ n)
+ (with-syntax ([(pv ...) (map (λ (_) (gensym))
+ (range (syntax-e #'n)))])
+ #'(check-equal? (reverse (defs2 pv ...)) '(xyz pv ... www pv ...)))]))
+
+(define-syntax (check-defs2* stx)
+ (syntax-case stx ()
+ [(_ start end)
+ (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))])
+ #'(begin
+ (check-defs2 nᵢ)
+ ...))]))
+
+(check-equal? (reverse (defs2)) '(xyz www))
+(check-equal? (reverse (defs2 a)) '(xyz a www a))
+(check-equal? (reverse (defs2 a b)) '(xyz a b www a b))
+(check-equal? (reverse (defs2 a b c)) '(xyz a b c www a b c))
+(check-equal? (reverse (defs2 a b c d)) '(xyz a b c d www a b c d))
+(check-equal? (reverse (defs2 a b c d e)) '(xyz a b c d e www a b c d e))
+(check-defs2* 6 65) ;; continue tests with 6 till 65 pvars
+
+(define-syntax (defs3 stx)
+ (syntax-case stx ()
+ [(_)
+ #'(list (list-pvars))]
+ [(_ pv₀ pvᵢ ...)
+ #'(cons (list-pvars)
+ (let ()
+ (define/with-syntax pv₀ #'12321)
+ (defs3 pvᵢ ...)))]))
+
+(define-syntax (*expected-defs3 stx)
+ (syntax-case stx ()
+ [(_)
+ #'(list '())]
+ [(_ pvᵢ ... pvₙ)
+ #'(cons '(pvᵢ ... pvₙ)
+ (*expected-defs3 pvᵢ ...))]))
+(define-syntax-rule (expected-defs3 pv ...)
+ (reverse (*expected-defs3 pv ...)))
+
+(define-syntax (check-defs3 stx)
+ (syntax-case stx ()
+ [(_ n)
+ (with-syntax ([(pv ...) (map (λ (_) (gensym))
+ (range (syntax-e #'n)))])
+ #'(check-equal? (map reverse (defs3 pv ...))
+ (expected-defs3 pv ...)))]))
+
+(define-syntax (check-defs3* stx)
+ (syntax-case stx ()
+ [(_ start end)
+ (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))])
+ #'(begin
+ (check-defs3 nᵢ)
+ ...))]))
+
+(check-equal? (map reverse (defs3)) '(()))
+(check-equal? (map reverse (defs3 a)) '(() (a)))
+(check-equal? (map reverse (defs3 a b)) '(() (a) (a b)))
+(check-equal? (map reverse (defs3 a b c)) '(() (a) (a b) (a b c)))
+(check-equal? (map reverse (defs3 a b c d)) '(() (a) (a b) (a b c) (a b c d)))
+(check-equal? (map reverse (defs3 a b c d e))
+ '(() (a) (a b) (a b c) (a b c d) (a b c d e)))
+
+(check-equal? (expected-defs3) '(()))
+(check-equal? (expected-defs3 a) '(() (a)))
+(check-equal? (expected-defs3 a b) '(() (a) (a b)))
+(check-equal? (expected-defs3 a b c) '(() (a) (a b) (a b c)))
+(check-equal? (expected-defs3 a b c d) '(() (a) (a b) (a b c) (a b c d)))
+(check-equal? (expected-defs3 a b c d e)
+ '(() (a) (a b) (a b c) (a b c d) (a b c d e)))
+
+(check-defs3* 6 65) ;; continue tests with 6 till 65 pvars
+\ No newline at end of file
