From 0ee1714c114a0b9a8025fc4dfc9227a37ddfa052 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 27 Jun 2011 17:57:08 -0600
Subject: [PATCH] Adding a simple testing mode library

---
 collects/racket/info.rkt              |    3 +++
 collects/racket/private/test-help.rkt |   32 ++++++++++++++++++++++++++++++++
 collects/racket/private/test.rkt      |   23 +++++++++++++++++++++++
 collects/racket/test.rkt              |   18 ++++++++++++++++++
 collects/tests/racket/testing/a.rkt   |   13 +++++++++++++
 collects/tests/racket/testing/b.rkt   |   15 +++++++++++++++
 collects/tests/racket/testing/c.rkt   |   13 +++++++++++++
 7 files changed, 117 insertions(+), 0 deletions(-)
 create mode 100644 collects/racket/info.rkt
 create mode 100644 collects/racket/private/test-help.rkt
 create mode 100644 collects/racket/private/test.rkt
 create mode 100644 collects/racket/test.rkt
 create mode 100644 collects/tests/racket/testing/a.rkt
 create mode 100644 collects/tests/racket/testing/b.rkt
 create mode 100644 collects/tests/racket/testing/c.rkt

diff --git a/collects/racket/info.rkt b/collects/racket/info.rkt
new file mode 100644
index 0000000..b3cbcd7
--- /dev/null
+++ b/collects/racket/info.rkt
@@ -0,0 +1,3 @@
+#lang setup/infotab
+(define raco-commands
+  '(("test" racket/private/test "run Racket programs in test mode" 50)))
diff --git a/collects/racket/private/test-help.rkt b/collects/racket/private/test-help.rkt
new file mode 100644
index 0000000..4eabb30
--- /dev/null
+++ b/collects/racket/private/test-help.rkt
@@ -0,0 +1,32 @@
+#lang racket/base
+(require setup/dirs
+         racket/match
+         racket/path)
+
+; : box (boolean or src-mod)
+(define who-am-i-testing? (box #f))
+
+(define (should-test? src-mod)
+  (cond
+    [(not (unbox who-am-i-testing?))
+     #f]
+    [(boolean? (unbox who-am-i-testing?))
+     #t]
+    [else
+     (let loop ([collects (explode-path (find-collects-dir))]
+                [statics (explode-path src-mod)]
+                [dynamics (explode-path (unbox who-am-i-testing?))])
+       (match* (collects statics dynamics)
+               [((cons collect n-collects)
+                 (cons static n-statics)
+                 (cons dynamic n-dynamics))
+                (if (equal? collect dynamic)
+                    (loop n-collects n-statics n-dynamics)
+                    (equal? statics dynamics))]
+               [(_
+                 (cons static n-statics)
+                 (cons dynamic n-dynamics))
+                (equal? statics dynamics)]))]))
+
+(provide who-am-i-testing?
+         should-test?)
\ No newline at end of file
diff --git a/collects/racket/private/test.rkt b/collects/racket/private/test.rkt
new file mode 100644
index 0000000..06fa88f
--- /dev/null
+++ b/collects/racket/private/test.rkt
@@ -0,0 +1,23 @@
+#lang racket/base
+(require raco/command-name
+         racket/private/test-help
+         racket/cmdline)
+
+(define all? #f)
+
+(define source-file
+  (command-line
+   #:program (short-program+command-name)
+   #:once-any
+   [("--all") "Run all required modules in testing mode"
+              (set! all? #t)]
+   [("--only") "Run only this module in testing mode"
+               (set! all? #f)]
+   #:args (source-file)
+   source-file))
+
+(if all?
+    (set-box! who-am-i-testing? #t)
+    (set-box! who-am-i-testing? (path->complete-path source-file)))
+
+(dynamic-require source-file #f)
\ No newline at end of file
diff --git a/collects/racket/test.rkt b/collects/racket/test.rkt
new file mode 100644
index 0000000..bbdc00c
--- /dev/null
+++ b/collects/racket/test.rkt
@@ -0,0 +1,18 @@
+#lang racket/base
+(require racket/private/test-help
+         racket/block
+         (for-syntax racket/base))
+
+(define-syntax (when-testing stx)
+  (syntax-case stx ()
+    [(_ . e)
+     (quasisyntax/loc stx
+       (when (should-test? #,(syntax-source stx))
+         (block . e)))]))
+
+(define-syntax-rule (when-deploying . e)
+  (when (not (unbox who-am-i-testing?))
+    (block . e)))
+
+(provide when-testing
+         when-deploying)
\ No newline at end of file
diff --git a/collects/tests/racket/testing/a.rkt b/collects/tests/racket/testing/a.rkt
new file mode 100644
index 0000000..0e41d09
--- /dev/null
+++ b/collects/tests/racket/testing/a.rkt
@@ -0,0 +1,13 @@
+#lang racket/base
+(require racket/test
+         tests/eli-tester
+         "b.rkt")
+
+(define (f x)
+  (+ 2 (g x)))
+
+(when-testing
+ (test (f 2) => 8))
+
+(when-deploying
+ (printf "a running!\n"))
\ No newline at end of file
diff --git a/collects/tests/racket/testing/b.rkt b/collects/tests/racket/testing/b.rkt
new file mode 100644
index 0000000..fce4441
--- /dev/null
+++ b/collects/tests/racket/testing/b.rkt
@@ -0,0 +1,15 @@
+#lang racket/base
+(require racket/test
+         tests/eli-tester
+         "c.rkt")
+
+(define (g x)
+  (+ 3 (h x)))
+
+(when-testing
+ (test (g 2) => 6))
+
+(when-deploying
+ (printf "b running!\n"))
+
+(provide g)
\ No newline at end of file
diff --git a/collects/tests/racket/testing/c.rkt b/collects/tests/racket/testing/c.rkt
new file mode 100644
index 0000000..0b8dac2
--- /dev/null
+++ b/collects/tests/racket/testing/c.rkt
@@ -0,0 +1,13 @@
+#lang racket/base
+(require racket/test
+         tests/eli-tester)
+
+(define h add1)
+
+(when-testing
+ (test (h 2) => 3))
+
+(when-deploying
+ (printf "c running!\n"))
+
+(provide h)
\ No newline at end of file
-- 
1.7.5.2