Adding module**, when-testing, and raco test

collects/compiler/commands/info.rkt

@@ -6,6 +6,7 @@
     ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)
     ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" 10)
     ("decompile" compiler/commands/decompile "decompile bytecode" #f)
+    ("test" compiler/commands/test "run all tests associated with a set of paths" #f)
     ("expand" compiler/commands/expand "macro-expand source" #f)
     ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
     ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)

collects/compiler/commands/test.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+(require racket/cmdline
+         racket/match
+         racket/path
+         raco/command-name)
+
+(define do-test
+  (match-lambda
+   [(? string? s)
+    (do-test (string->path s))]
+   [(? path? p)
+    (cond
+      [(directory-exists? p)
+       (for-each
+        (λ (dp)
+          (do-test (build-path p dp)))
+        (directory-list p))]
+      [(file-exists? p)
+       (define mod `(submod (file ,(path->string p)) test))
+       (when (module-declared? mod #t)
+         (dynamic-require mod #f))]
+      [else
+       (error 'test "Given path ~e does not exist" p)])]))
+
+(command-line
+ #:program (short-program+command-name)
+ #:args files+directories
+ (for-each do-test files+directories))

collects/meta/props

@@ -604,6 +604,7 @@ path/s is either such a string or a list of them.
 "collects/compiler/commands/exe.rkt" drdr:command-line #f
 "collects/compiler/commands/make.rkt" drdr:command-line (mzc *)
 "collects/compiler/commands/pack.rkt" drdr:command-line #f
+"collects/compiler/commands/test.rkt" responsible (jay)
 "collects/compiler/demodularizer" responsible (jay)
 "collects/compiler/demodularizer/batch.rkt" drdr:command-line #f
 "collects/compiler/demodularizer/prims.rkt" drdr:command-line #f
@@ -1178,6 +1179,7 @@ path/s is either such a string or a list of them.
 "collects/racket/match" responsible (samth)
 "collects/racket/match.rkt" responsible (samth)
 "collects/racket/place" responsible (tewk)
+"collects/racket/submodule.rkt" responsible (jay)
 "collects/racklog" responsible (jay)
 "collects/rackunit" responsible (jay noel ryanc)
 "collects/rackunit/gui.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)

collects/racket/submodule.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+(require (for-syntax racket/base))
+
+(begin-for-syntax
+  (define module->submodule->stxs-box (make-hash))
+  (define (lang=? x y)
+    (cond
+      [(and (identifier? x)
+             (identifier? y))
+       (free-identifier=? x y)]
+      [(and (not (syntax->datum x))
+            (not (syntax->datum y)))
+       #t]
+      [else
+       #f]))
+  (define (get-stxs-box the-submodule-stx lang-stx)
+    (define the-module (syntax-source-module the-submodule-stx))
+    (define submodule->stxs-box
+      (hash-ref! module->submodule->stxs-box the-module make-hash))
+    (define the-submodule-id
+      (syntax->datum the-submodule-stx))
+    (define lang-stx*stxs-box
+      (hash-ref! submodule->stxs-box the-submodule-id
+                 (λ ()
+                   (when lang-stx
+                     (syntax-local-lift-module-end-declaration
+                      (quasisyntax/loc the-submodule-stx
+                        (define-module #,the-submodule-stx))))
+                   (cons lang-stx (box null)))))
+    (values (car lang-stx*stxs-box)
+            (cdr lang-stx*stxs-box))))
+
+(define-syntax (module** stx)
+  (syntax-case stx ()
+    [(_ the-submodule lang e ...)
+     (begin
+       ;; This looks it up the first time and is allowed to create a
+       ;; list if necessary
+       (define-values (lang-should-be _)
+         (get-stxs-box #'the-submodule #'lang))
+       (unless (lang=? #'lang lang-should-be)
+         (raise-syntax-error 'module** (format "All occurrences of module** for the same submodule should use the same language position; given ~e, where previous use had ~e" #'lang lang-should-be)))
+       #'(begin-for-syntax
+           (define-values (_ stxs-box)
+             (get-stxs-box #'the-submodule #f))
+           (set-box! stxs-box
+                     (append (unbox stxs-box)
+                             (syntax->list #'(e ...))))))]))
+
+(define-syntax (define-module stx)
+  (syntax-case stx ()
+    [(_ the-submodule)
+     (begin
+       (define-values (lang-stx stxs-box)
+         (get-stxs-box #'the-submodule #f))
+       (quasisyntax/loc #'the-submodule
+         (module* the-submodule #,lang-stx
+           #,@(unbox stxs-box))))]))
+
+(define-syntax-rule (define-shorthand when-testing test)
+  (define-syntax (when-testing stx)
+    (syntax-case stx ()
+      [(_ e (... ...))
+       (quasisyntax/loc stx
+         (module** #,(datum->syntax stx 'test) #f 
+           e (... ...)))])))
+(define-shorthand when-testing test)
+
+(provide module**
+         when-testing)

collects/scribblings/raco/raco.scrbl

@@ -26,4 +26,5 @@ a typical Racket installation.
 @include-section["decompile.scrbl"]
 @include-section["demod.scrbl"]
 @include-section["ctool.scrbl"]
+@include-section["test.scrbl"]
 @include-section["command.scrbl"]

collects/scribblings/raco/test.scrbl

@@ -0,0 +1,12 @@
+#lang scribble/doc
+@(require scribble/manual 
+          "common.rkt" 
+          (for-label racket/runtime-path
+                     launcher/launcher))
+
+@title[#:tag "test"]{@exec{raco test}: Run tests}
+
+The @exec{raco test} command requires and runs the @racket['test]
+submodules associated with paths given on the command line. When a
+path refers to a directory, the tool recursively discovers all
+internal files and inspects them as well.

collects/scribblings/reference/syntax.scrbl

@@ -11,6 +11,7 @@
                      racket/package
                      racket/splicing
                      racket/runtime-path
+                     racket/submodule
                      racket/performance-hint))
 
 @(define require-eval (make-base-eval))
@@ -313,12 +314,32 @@ The @racket[#%module-begin] form of @racketmodname[racket/base] wraps
 every top-level expression to print non-@|void-const| results using
 @racket[current-print].}
 
-
 @defform[(#%plain-module-begin form ...)]{
 
 Legal only in a @tech{module begin context}, and handled by the
 @racket[module] and @racket[module*] forms.}
 
+
+@;------------------------------------------------------------------------
+@subsection[#:tag "submodule"]{Submodule helpers: @racket[module**]}
+
+@note-lib-only[racket/submodule]
+
+@defform*[((module** id module-path form ...)
+           (module** id #f form ...))]{
+
+Like @racket[module*], but multiple occurrences of @racket[module**]
+defining the same @tech{submodule} will be spliced together into a
+single module at the end of the enclosing module. Each occurrence must
+use the same form for the initial bindings of the submodule. }
+
+@defform[(when-testing form ...)]{
+
+ An abbreviation of @racket[(module** test #f form ...)]; useful for
+ embedding tests while spreading them throughout your
+ modules. Cooperates with @exec{raco test}.
+}
+
 @;------------------------------------------------------------------------
 @section[#:tag '("require" "provide")]{Importing and Exporting: @racket[require] and @racket[provide]}
 

collects/tests/compiler/test/a.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+(error 'dont-run)
+(module test racket/base
+  (printf "a\n"))

collects/tests/compiler/test/b.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+(error 'dont-run)
+(module test racket/base
+  (printf "b\n"))

collects/tests/compiler/test/d/c.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+(error 'dont-run)
+(module test racket/base
+  (printf "c\n"))

collects/tests/compiler/test/d/d.rkt

@@ -0,0 +1 @@
+#lang racket/base

collects/tests/racket/submodule.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+
+(module fac1 racket/base
+  (printf "fac1 running\n")
+  (require racket/submodule)  
+  (define (! n)
+    (if (zero? n)
+      1
+      (* n (! (sub1 n)))))
+  (module** test #f
+    (printf "fac1 testing\n")
+    (require rackunit)
+    (check-equal? (! 0) 1))
+  (module** test #f
+    (check-equal? (! 1) 1)
+    (check-equal? (! 5) 120)))
+
+(require (submod 'fac1 test))
+
+(module fac2 racket/base
+  (printf "fac2 running\n")
+  (require racket/submodule)
+  (define (! n)
+    (if (zero? n)
+      1
+      (* n (! (sub1 n)))))
+  (when-testing
+    (printf "fac2 testing\n")
+    (require rackunit)
+    (check-equal? (! 0) 1))
+  (when-testing
+    (check-equal? (! 1) 1)
+    (check-equal? (! 5) 120)))
+
+(require (submod 'fac2 test))
+
+(module fac3 racket/base
+  (printf "fac3 running\n")
+  (require racket/submodule)
+  (define (! n)
+    (if (zero? n)
+      1
+      (* n (! (sub1 n)))))
+  (module** test #f
+    (printf "fac3 testing\n")
+    (require rackunit)
+    (check-equal? (! 0) 1))
+  (when-testing
+    (check-equal? (! 1) 1)
+    (check-equal? (! 5) 120)))
+
+(require (submod 'fac3 test))