planet-requires moved to tests/typed-scheme/util-tests

svn: r11937

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)))

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 (r:infer infer infer-dummy)
-
+         (schemeunit))
-(require (schemeunit))
 
 (provide unit-tests)
 

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 "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
-(require (utils planet-requires)
+(require (rep type-rep)
-	 (rep type-rep)
 	 (r:infer infer)
 	 (private type-effect-convenience union type-utils)
-         (prefix-in table: (utils tables)))
+         (prefix-in table: (utils tables))
-(require (schemeunit)) 
+         (schemeunit))
 
 
 

collects/tests/typed-scheme/unit-tests/module-tests.ss

@@ -1,6 +1,5 @@
 #lang scheme
-(require "test-utils.ss")
+(require "test-utils.ss" "planet-requires.ss")
-(require (utils planet-requires))
 (require (schemeunit))
 
 (provide module-tests)

collects/tests/typed-scheme/unit-tests/new-fv-tests.ss

@@ -1,6 +1,6 @@
 (module new-fv-tests mzscheme
-  (require "test-utils.ss")
+  (require "test-utils.ss" "planet-requires.ss")
-  (require/private type-rep rep-utils planet-requires type-effect-convenience meet-join subtype union)
+  (require/private type-rep rep-utils type-effect-convenience meet-join subtype union)
   (require-schemeunit)
 
   (define variance-gen (random-uniform Covariant Contravariant Invariant Constant))

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 "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
-(require (utils planet-requires tc-utils)
+(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!

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"))

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))
+	 (private type-effect-convenience remove-intersect subtype union)
-
+         (schemeunit))
-(require (schemeunit))
 
 (define-syntax (restr-tests stx)    
   (syntax-case stx ()

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 "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
-(require (utils planet-requires)
+(require (rep type-rep)
-	 (rep type-rep)
+	 (private type-utils type-effect-convenience)
-	 (private type-utils type-effect-convenience))
+         (schemeunit))
-(require (schemeunit))
 
 (define-syntax-rule (s img var tgt result)
   (test-eq? "test" (substitute img 'var tgt) result))

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))
+	 (r:infer infer infer-dummy)
-
+         (schemeunit)
-
-(require (schemeunit)
          (for-syntax scheme/base))
 
 (provide subtype-tests)

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)

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)
+	 (utils tc-utils)
-	 (rep type-rep))
+	 (rep type-rep)
-
+         (schemeunit))
-(require (schemeunit))
 
 (provide type-annotation-tests)
 

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 "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
-(require (utils planet-requires) (rep type-rep)
+(require (rep type-rep)
-	 (private type-comparison type-effect-convenience union subtype))
+	 (private type-comparison type-effect-convenience union subtype)
-(require (schemeunit))
+         (schemeunit))
 
 (provide type-equal-tests)
 

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)
+         (utils tc-utils)
-         (env type-name-env type-environments init-envs))
+         (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))
-