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

Add typed-untyped interaction test harness

Browse Source
This commit is contained in:
Asumu Takikawa 2014-05-16 14:18:02 -04:00
parent b4d6f0516d
commit 5905fbd92a
1 changed files with 69 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
View File

@ -1,13 +1,15 @@
#lang scheme/base
(require "test-utils.rkt"
(for-syntax scheme/base)
(for-syntax scheme/base
syntax/parse)
(for-template scheme/base)
(private type-contract)
(rep type-rep)
(types abbrev numeric-tower union)
(static-contracts combinators optimize)
(submod typed-racket/private/type-contract numeric-contracts)
(only-in racket/contract contract)
rackunit)
(provide tests)
(gen-test-main)
@ -52,6 +54,62 @@
(with-check-info (('reason reason))
(fail-check "Reason didn't match expected.")))))))
;; construct a namespace for use in typed-untyped interaction tests
(define (ctc-namespace)
(parameterize ([current-namespace (make-base-namespace)])
(namespace-require 'racket/contract)
(namespace-require 'unstable/contract)
(namespace-require 'typed-racket/utils/any-wrap)
(namespace-require '(submod typed-racket/private/type-contract predicates))
(current-namespace)))
;; (t-int type (-> any any) any)
;; Use #:typed (default) to simulate typed export,
;; #:untyped for untyped export.
(define-syntax-rule (t-int arg ...)
(t-int/check arg ... check-not-exn))
(define (check-re re)
(λ (thunk)
(check-exn
(λ (e)
(and (exn:fail? e)
(regexp-match? re (exn-message e))))
thunk)))
;; (t-int/fail type (-> any any) any #:msg regexp)
;; Like t-int, but checks failing cases. Takes a regexp for checking
;; the exception message.
(define-syntax-rule (t-int/fail arg ... #:msg re)
(t-int/check arg ... (check-re re)))
;; tests typed-untyped interaction
(define-syntax (t-int/check stx)
(syntax-parse stx
[(_ type-expr fun-expr val-expr
(~or (~and (~or (~seq) (~seq #:typed))
(~bind [typed-side #'#t]))
(~and (~seq #:untyped)
(~bind [typed-side #'#f])))
check)
(define pos (if (syntax-e #'typed-side) 'typed 'untyped))
(define neg (if (syntax-e #'typed-side) 'untyped 'typed))
#`(test-case (format "~a for ~a in ~a" 'type-expr 'val-expr 'fun-expr)
(let ([type-val type-expr] [fun-val fun-expr] [val val-expr])
(with-check-info (['type type-val] ['test-value val])
(define ctc-stx
(type->contract type-val
#:typed-side typed-side
(λ (#:reason [reason #f])
(fail-check (or reason "Type could not be converted to contract")))))
(define ctced-val
(eval #`(contract #,(syntax-shift-phase-level ctc-stx 1)
#,val
#,(quote (quote #,pos))
#,(quote (quote #,neg)))
(ctc-namespace)))
(check (λ () (fun-val ctced-val))))))]))
(define tests
(test-suite "Contract Tests"
(t (-Number . -> . -Number))
@ -145,4 +203,14 @@
(member-spec 'field 'y integer/sc)
(member-spec 'inherit-field 'y integer/sc))
#f null null))
(t-int (-poly (a) (-> a a))
(λ (f) (f 1))
(λ (x) 1)
#:typed)
(t-int/fail (-poly (a) (-> a a))
(λ (f) (f 1))
(λ (x) 1)
#:untyped
#:msg #rx"produced: 1.*blaming: untyped")
))