From 2899c1f1cce30f7aacb5032e92c87cf06378722c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 03:40:55 +0000 Subject: [PATCH] planet-requires moved to tests/typed-scheme/util-tests svn: r11937 --- collects/tests/typed-scheme/main.ss | 2 +- .../typed-scheme/unit-tests/all-tests.ss | 6 +- .../typed-scheme/unit-tests/infer-tests.ss | 9 ++- .../typed-scheme/unit-tests/module-tests.ss | 3 +- .../typed-scheme/unit-tests/new-fv-tests.ss | 8 +-- .../unit-tests/parse-type-tests.ss | 9 ++- .../unit-tests/planet-requires.ss | 64 +++++++++++++++++++ .../unit-tests/remove-intersect-tests.ss | 8 +-- .../typed-scheme/unit-tests/subst-tests.ss | 9 ++- .../typed-scheme/unit-tests/subtype-tests.ss | 9 +-- .../typed-scheme/unit-tests/test-utils.ss | 7 +- .../unit-tests/type-annotation-test.ss | 9 ++- .../unit-tests/type-equal-tests.ss | 8 +-- .../unit-tests/typecheck-tests.ss | 9 ++- 14 files changed, 107 insertions(+), 53 deletions(-) create mode 100644 collects/tests/typed-scheme/unit-tests/planet-requires.ss diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss index b4fe5d20c1..76e7a139f0 100644 --- a/collects/tests/typed-scheme/main.ss +++ b/collects/tests/typed-scheme/main.ss @@ -86,7 +86,7 @@ (define (go) (test/gui tests)) (define (go/text) (test/text-ui tests)) - +(go/text) (when (getenv "PLT_TESTS") (unless (parameterize ([current-output-port (open-output-string)]) (= 0 (go/text))) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 1fe728d05b..ec859fed7f 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -2,6 +2,7 @@ (require "test-utils.ss" + "planet-requires.ss" "typecheck-tests.ss" "subtype-tests.ss" ;; done "type-equal-tests.ss" ;; done @@ -12,9 +13,8 @@ "subst-tests.ss" "infer-tests.ss") -(require (utils planet-requires) (r:infer infer infer-dummy)) - -(require (schemeunit)) +(require (r:infer infer infer-dummy) + (schemeunit)) (provide unit-tests) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index aef624b748..bf3b7b95ec 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,11 +1,10 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) (r:infer infer) (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables))) -(require (schemeunit)) + (prefix-in table: (utils tables)) + (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 490c1c2a89..decc67820c 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,5 @@ #lang scheme -(require "test-utils.ss") -(require (utils planet-requires)) +(require "test-utils.ss" "planet-requires.ss") (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss index 7e24d23ca2..d9ca47239b 100644 --- a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss @@ -1,8 +1,8 @@ (module new-fv-tests mzscheme - (require "test-utils.ss") - (require/private type-rep rep-utils planet-requires type-effect-convenience meet-join subtype union) - (require-schemeunit) - + (require "test-utils.ss" "planet-requires.ss") + (require/private type-rep rep-utils type-effect-convenience meet-join subtype union) + (require-schemeunit) + (define variance-gen (random-uniform Covariant Contravariant Invariant Constant)) (define alpha-string (random-string (random-char (random-int-between 65 90)) (random-size 1))) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index fedf84fb81..b40e131b1f 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,17 +1,16 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires tc-utils) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (utils tc-utils) (env type-alias-env type-environments type-name-env init-envs) (rep type-rep) (private type-comparison parse-type subtype - union type-utils)) + union type-utils) + (schemeunit)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) (for-template (private base-types))) -(require (schemeunit)) - (provide parse-type-tests) ;; HORRIBLE HACK! diff --git a/collects/tests/typed-scheme/unit-tests/planet-requires.ss b/collects/tests/typed-scheme/unit-tests/planet-requires.ss new file mode 100644 index 0000000000..038b3fb17e --- /dev/null +++ b/collects/tests/typed-scheme/unit-tests/planet-requires.ss @@ -0,0 +1,64 @@ +#lang scheme/base + +(require (for-syntax scheme/base scheme/require-transform) + scheme/require-syntax) + +(define-for-syntax (splice-requires specs) + (define subs (map (compose cons expand-import) specs)) + (values (apply append (map car subs)) (apply append (map cdr subs)))) + +(define-syntax define-module + (syntax-rules () + [(_ nm spec ...) + + (define-syntax nm + (make-require-transformer + (lambda (stx) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))) + #; + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))])) + +#; +(define-syntax define-module + (lambda (stx) + (syntax-case stx () + [(_ nm spec ...) + (syntax/loc stx + (define-syntax nm + (make-require-transformer + (lambda (stx) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))]))) + +(define-syntax planet/multiple + (make-require-transformer + (lambda (stx) + (syntax-case stx () + [(_ plt files ...) + (let ([mk (lambda (spc) + (syntax-case spc (prefix-in) + [e + (string? (syntax-e #'e)) + (datum->syntax spc `(planet ,#'e ,#'plt) spc)] + [(prefix-in p e) + (datum->syntax spc `(prefix-in ,#'p (planet ,#'e ,#'plt)) spc)]))]) + (splice-requires (map mk (syntax->list #'(files ...)))))])))) + + +(provide schemeunit) +;; why is this neccessary? +(provide planet/multiple) + +(define-module schemeunit + (planet/multiple ("schematics" "schemeunit.plt" 2 3) + "test.ss" + ;"graphical-ui.ss" + "text-ui.ss" + "util.ss") + ;; disabled until Carl updates to v4 + #; + (planet/multiple ("cce" "fasttest.plt" 1 2) + "random.ss" + "schemeunit.ss")) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 20da5c73c3..e18cd04b91 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,11 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (utils planet-requires) (r:infer infer) - (private type-effect-convenience remove-intersect subtype union)) - -(require (schemeunit)) + (private type-effect-convenience remove-intersect subtype union) + (schemeunit)) (define-syntax (restr-tests stx) (syntax-case stx () diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 10a35fc98a..91d42cd426 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (private type-utils type-effect-convenience)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-utils type-effect-convenience) + (schemeunit)) (define-syntax-rule (s img var tgt result) (test-eq? "test" (substitute img 'var tgt) result)) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 83bb3e9a51..6aac041abb 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "test-utils.ss") +(require "test-utils.ss" "planet-requires.ss") (require (private subtype type-effect-convenience union) (rep type-rep) - (utils planet-requires) (env init-envs type-environments) - (r:infer infer infer-dummy)) - - -(require (schemeunit) + (r:infer infer infer-dummy) + (schemeunit) (for-syntax scheme/base)) (provide subtype-tests) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index b160cacdf9..9c40943939 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -1,15 +1,16 @@ #lang scheme/base (provide (all-defined-out)) -(require scheme/require-syntax +(require "planet-requires.ss" + scheme/require-syntax scheme/match typed-scheme/utils/utils (for-syntax scheme/base)) -(require (utils planet-requires) (private type-comparison type-utils)) +(require (private type-comparison type-utils) + (schemeunit)) (provide private typecheck (rename-out [infer r:infer]) utils env rep) -(require (schemeunit)) (define (mk-suite ts) (match (map (lambda (f) (f)) ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 167db51eb7..9f5398e72a 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,12 +1,11 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (private type-annotation type-effect-convenience parse-type) (env type-environments type-name-env init-envs) - (utils planet-requires tc-utils) - (rep type-rep)) - -(require (schemeunit)) + (utils tc-utils) + (rep type-rep) + (schemeunit)) (provide type-annotation-tests) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 899b8e1e97..1e4c5c2202 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,9 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) (rep type-rep) - (private type-comparison type-effect-convenience union subtype)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-comparison type-effect-convenience union subtype) + (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 5506b1ff4f..0be4c518f5 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -1,21 +1,20 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base) (for-template scheme/base)) (require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) (typecheck typechecker) (rep type-rep effect-rep) - (utils tc-utils planet-requires) - (env type-name-env type-environments init-envs)) + (utils tc-utils) + (env type-name-env type-environments init-envs) + (schemeunit)) (require (for-syntax (utils tc-utils) (typecheck typechecker) (env type-env) (private base-env)) (for-template (private base-env base-types))) -(require (schemeunit)) -