From ae9a8c9f25e50d530ad13a6d9bd6b01b9cd4ff4b Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 7 Oct 2013 20:19:59 -0700 Subject: [PATCH] Moved static-contract tests to TR test directory. --- .../static-contracts/optimize.rkt | 86 ----------------- .../typed-racket/static-contracts/tests.rkt | 71 -------------- .../typed-racket/utils/utils.rkt | 2 +- .../typed-racket/unit-tests/all-tests.rkt | 2 + .../static-contract-conversion-tests.rkt | 71 ++++++++++++++ .../static-contract-optimizer-tests.rkt | 93 +++++++++++++++++++ .../typed-racket/unit-tests/test-utils.rkt | 2 +- 7 files changed, 168 insertions(+), 159 deletions(-) delete mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/tests.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt index 0674acff2d..52687619d9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt @@ -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))))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/tests.rkt deleted file mode 100644 index 50abd0ab55..0000000000 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/tests.rkt +++ /dev/null @@ -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)) - diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt index ae2d0f7700..e59ae4d2d4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 945b78501f..411b746c5f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -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" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt new file mode 100644 index 0000000000..4f4866ef52 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt @@ -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)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt new file mode 100644 index 0000000000..3d6c6bfa96 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt @@ -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)))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/test-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/test-utils.rkt index 505f463aa6..6ee79ac4fe 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/test-utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/test-utils.rkt @@ -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