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

Make contract obligation tests more mobust.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-03-29 13:36:53 -05:00
parent a4d569ae31
commit 3c074249a0
2 changed files with 16 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test/tests/racket/contract/obligations.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
(require "test-util.rkt")
(require "test-util.rkt"
racket/list)
(parameterize ([current-contract-namespace
(make-basic-contract-namespace)])
(define (test-obligations quoted-expr expected-props)
(define (cleanup key obj stx)
(define ((cleanup key stx) obj)
(case key
[(racket/contract:contract)
(define (cleanup-ent x)
@ -21,21 +22,25 @@
(error 'test-obligations "unknown property ~s" key)]))
(let ([props '()])
(let ([stx (contract-expand-once quoted-expr)])
(let ([stx (contract-expand quoted-expr)])
(let loop ([stx stx])
(cond
[(syntax? stx)
(for ([key (in-list (syntax-property-symbol-keys stx))])
(when (regexp-match #rx"^racket/contract:" (symbol->string key))
(set! props (cons (cleanup key (syntax-property stx key) stx)
props))))
(syntax-case stx (#%top)
[(#%top . x)
(void)]
[_
(for ([key (in-list (syntax-property-symbol-keys stx))])
(when (regexp-match #rx"^racket/contract:" (symbol->string key))
(set! props (append (map (cleanup key stx) (flatten (syntax-property stx key)))
props))))])
(loop (syntax-e stx))]
[(pair? stx)
(loop (car stx))
(loop (cdr stx))])))
(test expected-props
`(obligations-for ,quoted-expr)
(sort props string<=? #:key (λ (x) (format "~s" x))))))
(remove-duplicates (sort props string<=? #:key (λ (x) (format "~s" x)))))))
(test-obligations '(-> a b)
'((racket/contract:contract (->) ())

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

@ -20,7 +20,7 @@
contract-eval
contract-compile
contract-expand-once
contract-expand
rewrite-to-add-opt/c
rewrite-to-double-wrap
@ -126,9 +126,9 @@
(parameterize ([current-namespace (current-contract-namespace)])
(compile x)))
(define (contract-expand-once x)
(define (contract-expand x)
(parameterize ([current-namespace (current-contract-namespace)])
(expand-once x)))
(expand x)))
(define-syntax (ctest stx)
(syntax-case stx ()