From 3d347f117b9ba648536094eb9e0bf1ab1653ea76 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 1 Jul 2010 13:47:02 -0400
Subject: [PATCH] Add --just flag for running tests.

---
 collects/tests/typed-scheme/main.rkt | 45 ++++++++++++++++++++--------
 collects/tests/typed-scheme/run.rkt  | 13 ++++----
 2 files changed, 39 insertions(+), 19 deletions(-)

diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt
index ac68c30a97..418df65427 100644
--- a/collects/tests/typed-scheme/main.rkt
+++ b/collects/tests/typed-scheme/main.rkt
@@ -23,8 +23,9 @@
                          [(number? e)
                           (and (exn:fail:syntax? val)
                                (= e (length (exn:fail:syntax-exprs val))))]
-                         [else                          
-                          (regexp-match e (exn-message val))]))))
+                         [(or (string? e) (regexp? e))
+                          (regexp-match e (exn-message val))]
+                         [else (error 'exn-pred "bad argument" e)]))))
    args))
   
 (define (exn-pred p)
@@ -61,9 +62,8 @@
     (make-test-suite dir tests)))
 
 (define (dr p)
-  #;((compile-zos #f) (list p) 'auto)
   (parameterize ([current-namespace (make-base-empty-namespace)])    
-    (dynamic-require `(file ,(path->string p)) #f)))
+    (dynamic-require `(file ,(if (string? p) p (path->string p))) #f)))
 
 (define succ-tests (mk-tests "succeed" 
                              dr
@@ -86,16 +86,35 @@
   (test-suite "Typed Scheme Tests"
               unit-tests int-tests))
 
-(define (go [unit? #f] [int? #f]) (test/gui (cond [unit? unit-tests]
-                                                  [int? int-tests]
-                                                  [else tests])))
-(define (go/text [unit? #f] [int? #f]) (run-tests 
-                                        (cond [unit? unit-tests]
-                                              [int? int-tests]
-                                              [else tests])
-                                        'verbose))
+(provide tests int-tests unit-tests)
 
-(provide go go/text)
+(define (go tests) (test/gui tests))
+(define (go/text tests) (run-tests tests 'verbose))
+
+(define (just-one p*)
+  (define-values (path p b) (split-path p*))
+  (define f
+    (if (equal? "fail/" (path->string path))
+        (lambda (p thnk)
+          (define-values (pred info) (exn-pred p))
+          (parameterize ([error-display-handler void])
+            (with-check-info
+             (['predicates info])
+             (check-exn pred thnk))))
+        (lambda (p thnk) (check-not-exn thnk))))
+  (test-suite 
+   (path->string p)
+   (f
+    (build-path path p)
+    (lambda ()
+      (parameterize ([read-accept-reader #t]
+                     [current-load-relative-directory
+                      (path->complete-path path)]
+                     [current-directory path]
+                     [current-output-port (open-output-nowhere)])
+        (dr p))))))
+
+(provide go go/text just-one)
 
 
 
diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt
index efde19fed0..b2776667d5 100644
--- a/collects/tests/typed-scheme/run.rkt
+++ b/collects/tests/typed-scheme/run.rkt
@@ -4,22 +4,23 @@
 (require "main.ss")
 
 (define exec (make-parameter go/text))
-(define unit-only? (make-parameter #f))
-(define int-only? (make-parameter #f))
+(define the-tests (make-parameter tests))
 (define skip-all? #f)
 (current-namespace (make-base-namespace))
 (command-line
  #:once-each
- ["--unit" "run just the unit tests" (unit-only? #t)]
- ["--int" "run just the integration tests" (int-only? #t)]
+ ["--unit" "run just the unit tests" (the-tests unit-tests)]
+ ["--int" "run just the integration tests" (the-tests int-tests)]
  ["--nightly" "for the nightly builds" (when (eq? 'cgc (system-type 'gc))
                                          (set! skip-all? #t))]
+ ["--just" path "run only this test" (the-tests (just-one path))]
  ["--gui" "run using the gui" 
           (if (gui-available?)
               (begin (exec go))
-              (error "GUI not available"))])
+              (error "GUI not available"))]
+ )
 
 (if skip-all?
     (printf "Skipping Typed Racket tests.\n")
-    (unless (= 0 ((exec) (unit-only?) (int-only?)))
+    (unless (= 0 ((exec) (the-tests)))
       (error "Typed Racket Tests did not pass.")))