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

Moved static-contract tests to TR test directory.

Browse Source
This commit is contained in:
Eric Dobson 2013-10-07 20:19:59 -07:00
parent 43ce10b5fe
commit ae9a8c9f25
7 changed files with 168 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
View File

@ -67,89 +67,3 @@
((recur variance) sc 'covariant))
(module+ test
(require rackunit)
(provide optimizer-tests)
(define-check (check-optimize variance* argument* expected*)
(let ([variance variance*]
[argument argument*]
[expected expected*])
(with-check-info*
(list (make-check-info 'original argument)
(make-check-expected expected))
(lambda ()
(let ([opt (optimize argument variance)])
(with-check-info* (list (make-check-actual opt))
(lambda ()
(unless (equal? opt expected)
(fail-check)))))))))
(define optimizer-tests
(test-suite "Optimizer Tests"
(check-optimize 'covariant
(listof/sc any/sc)
any/sc)
(check-optimize 'contravariant
(listof/sc any/sc)
list?/sc)
(check-optimize 'covariant
(set/sc any/sc)
any/sc)
(check-optimize 'contravariant
(set/sc any/sc)
set?/sc)
(check-optimize 'covariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list (listof/sc any/sc)))
(function/sc (list list?/sc)
(list)
(list)
(list)
#f
#f))
(check-optimize 'contravariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list (listof/sc any/sc)))
(function/sc (list any/sc)
(list)
(list)
(list)
#f
(list list?/sc)))
(check-optimize 'contravariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list any/sc))
(function/sc (list any/sc)
(list)
(list)
(list)
#f
(list any/sc)))
(check-optimize 'covariant
(case->/sc empty)
(case->/sc empty))
(check-optimize 'contravariant
(case->/sc empty)
(case->/sc empty))
(check-optimize 'covariant
(parameter/sc list?/sc (flat/sc #'symbol?))
(parameter/sc list?/sc any/sc))
(check-optimize 'contravariant
(case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc)))))
(case->/sc (list (arr/sc (list any/sc) any/sc (list list?/sc)))))
(check-optimize 'covariant
(case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc)))))
(case->/sc (list (arr/sc (list list?/sc) (listof/sc set?/sc) #f)))))))

71
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/tests.rkt
View File

@ -1,71 +0,0 @@
#lang scheme/base
(require tests/typed-racket/unit-tests/test-utils
(for-syntax scheme/base)
(for-template scheme/base)
(types abbrev numeric-tower union)
rackunit
"types.rkt" "instantiate.rkt")
(define-syntax-rule (t e)
(test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract"))))))
(define-namespace-anchor anchor)
(define ns (namespace-anchor->empty-namespace anchor))
(define-syntax-rule (t/sc e)
(test-case (format "~a" e)
(define sc
(type->static-contract e (lambda _ (error "type could not be converted to static-contract"))))
(with-check-info (['static-contract sc])
(define ctc (instantiate sc (lambda _ (error "static-contract could not be converted to a contract"))))
(with-check-info (['contract (syntax->datum ctc)])
(eval-syntax ctc ns)))))
(define-syntax-rule (t/fail e)
(test-not-exn (format "~a" e) (lambda ()
(let/ec exit
(type->static-contract e (lambda _ (exit #t)))
(error "type could be converted to contract")))))
(define-syntax-rule (t/fail-import e)
(test-not-exn (format "~a" e) (lambda ()
(let/ec exit
(type->static-contract e (lambda _ (exit #t)) #:typed-side #f)
(error "type could be converted to contract")))))
(define contract-tests
(test-suite "Contract Tests"
(t/sc (-Number . -> . -Number))
(t/sc (cl->* (-> -Symbol)
(-Symbol . -> . -Symbol)))
(t/sc (cl->* (-> -Symbol)
(-Symbol -Symbol . -> . -Symbol)))
(t/sc (cl->* (-Symbol . -> . -Symbol)
(-Symbol -Symbol . -> . -Symbol)))
(t/sc (-Promise -Number))
(t/sc (-lst -Symbol))
(t/sc -Boolean)
(t/sc Univ)
(t/sc (-set Univ))
(t/sc (-poly (a) (-lst a)))
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol))
(t/fail-import (-poly (a) (-lst a)))
(t/sc (-mu a (-lst a)))
(t/sc (-mu a (-box a)))
(t/sc (-mu sexp (Un (-val '()) -Symbol (-pair sexp sexp) (-vec sexp) (-box sexp))))
(t/sc (-mu a (-> a a)))
(t/sc (-seq -Symbol))
))
(require (submod "optimize.rkt" test))
(define all-tests
(test-suite "All Tests"
contract-tests
optimizer-tests))
(require rackunit/text-ui)
(void (run-tests all-tests))

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt
View File

@ -17,7 +17,7 @@ at least theoretically.
;; logging
show-input?
;; provide macros
rep utils typecheck infer env private types)
rep utils typecheck infer env private types static-contracts)
(define optimize? (make-parameter #t))
(define-for-syntax enable-contracts? #f)

2
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt
View File

@ -23,6 +23,8 @@
"subtype-tests.rkt"
"type-equal-tests.rkt"
"remove-intersect-tests.rkt"
"static-contract-conversion-tests.rkt"
"static-contract-optimizer-tests.rkt"
"parse-type-tests.rkt"
"subst-tests.rkt"
"infer-tests.rkt"

71
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang racket/base
(require "test-utils.rkt" "evaluator.rkt"
rackunit
(only-in racket/contract contract?)
syntax/srcloc syntax/location
(for-syntax
syntax/parse
racket/base
(static-contracts types instantiate)
(types abbrev numeric-tower union)))
(provide tests)
(gen-test-main)
(define-syntax t/sc
(syntax-parser
[(_ e:expr)
(syntax/loc #'e
(test-case
(format "Conversion:~a" (quote-line-number e))
(with-check-info (['type 'e]
['location (build-source-location-list (quote-srcloc e))])
(phase1-phase0-eval
(define sc
(type->static-contract e (lambda _ #f)))
(if sc
#`(with-check-info (['static '#,sc])
(phase1-phase0-eval
(define ctc (instantiate '#,sc
(lambda _ (error "static-contract could not be converted to a contract"))))
#,#'#`(with-check-info (['contract '#,ctc])
(define runtime-contract #,ctc)
(check-pred contract? runtime-contract))))
#'(fail-check "Type could not be converted to a static contract"))))))]))
(define-syntax t/fail
(syntax-parser
[(_ e:expr (~optional (~seq #:typed-side typed-side) #:defaults ([typed-side #'#t])))
#`(test-case (format "~a" 'e)
(define sc
(phase1-phase0-eval
(let/ec exit
#`'#,(type->static-contract e (lambda _ (exit #'#f)) #:typed-side typed-side))))
(when sc
(with-check-info (['static sc])
(fail-check "Type was incorrectly converted to contract"))))]))
(define tests
(test-suite "Conversion Tests"
(t/sc (-Number . -> . -Number))
(t/sc (cl->* (-> -Symbol)
(-Symbol . -> . -Symbol)))
(t/sc (cl->* (-> -Symbol)
(-Symbol -Symbol . -> . -Symbol)))
(t/sc (cl->* (-Symbol . -> . -Symbol)
(-Symbol -Symbol . -> . -Symbol)))
(t/sc (-Promise -Number))
(t/sc (-lst -Symbol))
(t/sc -Boolean)
(t/sc Univ)
(t/sc (-set Univ))
(t/sc (-poly (a) (-lst a)))
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol))
(t/fail (-poly (a) (-lst a)) #:typed-side #f)
(t/sc (-mu a (-lst a)))
(t/sc (-mu a (-box a)))
(t/sc (-mu sexp (Un (-val '()) -Symbol (-pair sexp sexp) (-vec sexp) (-box sexp))))
(t/sc (-mu a (-> a a)))
(t/sc (-seq -Symbol))))

93
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt Normal file
View File

@ -0,0 +1,93 @@
#lang racket/base
(require "test-utils.rkt"
racket/list
rackunit
(static-contracts instantiate optimize combinators))
(provide tests)
(gen-test-main)
(define-check (check-optimize variance* argument* expected*)
(let ([variance variance*]
[argument argument*]
[expected expected*])
(with-check-info*
(list (make-check-info 'original argument)
(make-check-expected expected))
(lambda ()
(let ([opt (optimize argument variance)])
(with-check-info* (list (make-check-actual opt))
(lambda ()
(unless (equal? opt expected)
(fail-check)))))))))
(define tests
(test-suite "Static Contract Optimizer Tests"
(check-optimize 'covariant
(listof/sc any/sc)
any/sc)
(check-optimize 'contravariant
(listof/sc any/sc)
list?/sc)
(check-optimize 'covariant
(set/sc any/sc)
any/sc)
(check-optimize 'contravariant
(set/sc any/sc)
set?/sc)
(check-optimize 'covariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list (listof/sc any/sc)))
(function/sc (list list?/sc)
(list)
(list)
(list)
#f
#f))
(check-optimize 'contravariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list (listof/sc any/sc)))
(function/sc (list any/sc)
(list)
(list)
(list)
#f
(list list?/sc)))
(check-optimize 'contravariant
(function/sc (list (listof/sc any/sc))
(list)
(list)
(list)
#f
(list any/sc))
(function/sc (list any/sc)
(list)
(list)
(list)
#f
(list any/sc)))
(check-optimize 'covariant
(case->/sc empty)
(case->/sc empty))
(check-optimize 'contravariant
(case->/sc empty)
(case->/sc empty))
(check-optimize 'covariant
(parameter/sc list?/sc (flat/sc #'symbol?))
(parameter/sc list?/sc any/sc))
(check-optimize 'contravariant
(case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc)))))
(case->/sc (list (arr/sc (list any/sc) any/sc (list list?/sc)))))
(check-optimize 'covariant
(case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc)))))
(case->/sc (list (arr/sc (list list?/sc) (listof/sc set?/sc) #f))))))

2
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/test-utils.rkt
View File

@ -9,7 +9,7 @@
(rep type-rep)
rackunit rackunit/text-ui)
(provide private typecheck (rename-out [infer r:infer]) utils env rep types base-env
(provide private typecheck (rename-out [infer r:infer]) utils env rep types base-env static-contracts
(all-defined-out))
;; FIXME - do something more intelligent