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

Extend test suite to try double-wrapping everywhere.

Browse Source 
To provide additional testing for space-efficient wrappers.

Currently has some failures.
This commit is contained in:
Vincent St-Amour 2016-02-11 14:21:10 -06:00
parent 0e1f17b520
commit 6ee45a156d
1 changed files with 84 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
pkgs/racket-test/tests/racket/contract/test-util.rkt
View File

@ -23,6 +23,7 @@
contract-expand-once contract-expand-once
rewrite-to-add-opt/c rewrite-to-add-opt/c
rewrite-to-double-wrap
test-cases failures) test-cases failures)
@ -193,29 +194,36 @@
'(with-handlers ([exn:fail? exn-message]) '(with-handlers ([exn:fail? exn-message])
,new-expression ,new-expression
'no-exn-raised)))))) 'no-exn-raised))))))
(let/ec k (define (rewrite-test wrapper wrapper-name)
(contract-eval (let/ec k
#:test-case-name (format "~a rewrite-to-add-opt/c" name) (contract-eval
`(,test #:test-case-name ,(format "~a rewrite-to-add-opt/c" name) #:test-case-name (format "~a ~a" name wrapper-name)
'no-exn-raised `(,test #:test-case-name ,(format "~a ~a" name wrapper-name)
eval 'no-exn-raised
'(with-handlers ([exn:fail? exn-message]) eval
,(rewrite-to-add-opt/c expression k) '(with-handlers ([exn:fail? exn-message])
'no-exn-raised))))) ,(wrapper expression k)
'no-exn-raised)))))
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c")
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap"))
(define (test/spec-passed/result name expression result) (define (test/spec-passed/result name expression result)
(parameterize ([compile-enforce-module-constants #f]) (parameterize ([compile-enforce-module-constants #f])
(contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression)) (contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression))
(let/ec k (define (rewrite-test wrapper wrapper-name)
(define opt-rewrite-name (format "~a rewrite-to-add-opt/c" name)) (let/ec k
(contract-eval (define rewrite-name (format "~a ~a" name wrapper-name))
#:test-case-name opt-rewrite-name (contract-eval
`(,test #:test-case-name rewrite-name
#:test-case-name ,opt-rewrite-name `(,test
',result #:test-case-name ,rewrite-name
eval ',result
',(rewrite-to-add-opt/c expression k)))) eval
',(wrapper expression k)))))
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c")
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap")
(let ([new-expression (rewrite-out expression)]) (let ([new-expression (rewrite-out expression)])
(when new-expression (when new-expression
(define out-rewrite-name (format "~a rewrite-out" name)) (define out-rewrite-name (format "~a rewrite-out" name))
@ -299,19 +307,34 @@
(and rewrote? maybe-rewritten?)) (and rewrote? maybe-rewritten?))
;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. (define ((rewrite contract-case) exp k)
(define (rewrite-to-add-opt/c exp k)
(let loop ([exp exp]) (let loop ([exp exp])
(cond (cond
[(null? exp) null] [(null? exp) null]
[(list? exp) [(list? exp)
(case (car exp) (case (car exp)
[(contract) `(contract (opt/c ,(loop (cadr exp))) ,@(map loop (cddr exp)))] [(contract) (contract-case (cadr exp) (caddr exp) (cdddr exp) loop)]
[(module) (k #f)] [(module) (k #f)]
[else (map loop exp)])] [else (map loop exp)])]
[(pair? exp) (cons (loop (car exp)) [(pair? exp) (cons (loop (car exp))
(loop (cdr exp)))] (loop (cdr exp)))]
[else exp]))) [else exp])))
;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test.
(define rewrite-to-add-opt/c
(rewrite (lambda (ctc val parties loop)
`(contract (opt/c ,(loop ctc)) ,(loop val) ,@(map loop parties)))))
;; rewrites `contract` to double-wrap. To test space-efficient wrappers.
(define rewrite-to-double-wrap
(rewrite (lambda (ctc val parties loop)
(define new-ctc (loop ctc))
(define new-parties (map loop parties))
`(contract ,new-ctc
(contract ,(loop ctc)
,(loop val)
,@new-parties)
,@new-parties))))
;; blame : (or/c 'pos 'neg string?) ;; blame : (or/c 'pos 'neg string?)
;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message ;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message
@ -333,17 +356,20 @@
(lambda (exn) (lambda (exn)
(and (exn:fail:contract:blame? exn) (and (exn:fail:contract:blame? exn)
(,has-proper-blame? (exn-message exn)))))) (,has-proper-blame? (exn-message exn))))))
(let/ec k (define (rewrite-test wrapper wrapper-name short-wrapper-name)
(let ([rewritten (rewrite-to-add-opt/c expression k)]) (let/ec k
(contract-eval (let ([rewritten (wrapper expression k)])
#:test-case-name (format "~a rewrite-to-add-opt/c" name) (contract-eval
`(,test-an-error #:test-case-name (format "~a ~a" name wrapper-name)
',(string->symbol (format "~a+opt/c" name)) `(,test-an-error
(lambda () ,rewritten) ',(string->symbol (format "~a+~a" name short-wrapper-name))
',rewritten (lambda () ,rewritten)
(lambda (exn) ',rewritten
(and (exn:fail:contract:blame? exn) (lambda (exn)
(,has-proper-blame? (exn-message exn))))))))) (and (exn:fail:contract:blame? exn)
(,has-proper-blame? (exn-message exn)))))))))
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c" "opt/c")
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" "double"))
(define (test/pos-blame name expression) (test/spec-failed name expression 'pos)) (define (test/pos-blame name expression) (test/spec-failed name expression 'pos))
(define (test/neg-blame name expression) (test/spec-failed name expression 'neg)) (define (test/neg-blame name expression) (test/spec-failed name expression 'neg))
@ -351,15 +377,19 @@
(define-syntax (ctest/rewrite stx) (define-syntax (ctest/rewrite stx)
(syntax-case stx () (syntax-case stx ()
[(_ expected name expression) [(_ expected name expression)
(with-syntax ([opt-name (string->symbol (format "~a+opt/c" (syntax-e #'name)))]) (with-syntax ([opt-name (string->symbol (format "~a+opt/c" (syntax-e #'name)))]
[double-name (string->symbol (format "~a+double" (syntax-e #'name)))])
#'(begin #'(begin
(contract-eval #:test-case-name 'name `(,test expected 'name expression)) (contract-eval #:test-case-name 'name `(,test expected 'name expression))
(let/ec k (define (rewrite-test wrapper name)
(contract-eval (let/ec k
#:test-case-name 'opt-name (contract-eval
`(,test expected #:test-case-name name
'opt-name `(,test expected
,(rewrite-to-add-opt/c 'expression k))))))])) 'opt-name
,(wrapper 'expression k)))))
(rewrite-test 'opt-name rewrite-to-add-opt/c)
(rewrite-test 'double-name rewrite-to-double-wrap)))]))
(define (test/well-formed stx) (define (test/well-formed stx)
(contract-eval (contract-eval
@ -384,11 +414,14 @@
`(,test (void) `(,test (void)
eval eval
'(begin ,sexp (void)))) '(begin ,sexp (void))))
(let/ec k (define (rewrite-test wrapper wrapper-name)
(define rewritten (rewrite-to-add-opt/c sexp k)) (let/ec k
(define rewritten (wrapper sexp k))
(unless (equal? rewritten sexp) (unless (equal? rewritten sexp)
(contract-eval (contract-eval
#:test-case-name (format "~a:~a opt/c" fn line) #:test-case-name (format "~a:~a ~a" fn line wrapper-name)
`(,test (void) `(,test (void)
eval eval
'(begin ,rewritten (void))))))) '(begin ,rewritten (void)))))))
(rewrite-test rewrite-to-add-opt/c "opt/c")
(rewrite-test rewrite-to-double-wrap "double"))