racket/slice, expand raco test, remove begin-for-testing

collects/compiler/commands/test.rkt

@@ -4,25 +4,41 @@
          racket/path
          raco/command-name)
 
+(define submodule 'test)
+(define run-anyways? #f)
+
 (define do-test
   (match-lambda
    [(? string? s)
     (do-test (string->path s))]
    [(? path? p)
+    (define ps (path->string p))
     (cond
       [(directory-exists? p)
        (for-each
         (λ (dp)
           (do-test (build-path p dp)))
         (directory-list p))]
-      [(file-exists? p)
+      [(and (file-exists? p)
-       (define mod `(submod (file ,(path->string p)) test))
+            (regexp-match #rx"\\.rkt$" ps))
-       (when (module-declared? mod #t)
+       (define fmod `(file ,ps))
-         (dynamic-require mod #f))]
+       (define mod `(submod ,fmod ,submodule))
-      [else
+       (cond
+         [(module-declared? mod #t)
+          (dynamic-require mod #f)]
+         [(and run-anyways? (module-declared? fmod #t))
+          (dynamic-require fmod #f)])]
+      [(not (file-exists? p))
        (error 'test "Given path ~e does not exist" p)])]))
 
 (command-line
  #:program (short-program+command-name)
+ #:once-each
+ [("--submodule" "-s") submodule-str
+  "Determines which submodule to load"
+  (set! submodule (string->symbol submodule-str))]
+ [("--run-if-absent" "-r")
+  "When set, raco test will require the default module if the given submodule is not present."
+  (set! run-anyways? #t)]
  #:args files+directories
  (for-each do-test files+directories))

collects/meta/props

@@ -1179,7 +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/racket/slice.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" *)
@@ -1903,6 +1903,7 @@ path/s is either such a string or a list of them.
 "collects/tests/racket/struct.rktl" drdr:command-line (racket "-f" *)
 "collects/tests/racket/structlib.rktl" drdr:command-line (racket "-f" *)
 "collects/tests/racket/stx.rktl" drdr:command-line (racket "-f" *)
+"collects/tests/racket/slice.rkt" responsible (jay)
 "collects/tests/racket/subprocess.rktl" drdr:command-line (racket "-f" *) drdr:random #t
 "collects/tests/racket/sync.rktl" drdr:command-line #f
 "collects/tests/racket/syntax-tests.rktl" drdr:command-line (racket "-f" *)

collects/racket/slice.rkt

@@ -0,0 +1,47 @@
+#lang racket/base
+(require (for-syntax racket/base))
+
+(begin-for-syntax
+  (define module->submodule->stxs-box (make-weak-hash))
+  (define (get-stxs-box the-submodule-stx lift?)
+    (define the-module (syntax-source-module the-submodule-stx))
+    (define submodule->stxs-box
+      (hash-ref! module->submodule->stxs-box the-module make-weak-hasheq))
+    (define the-submodule-id
+      (syntax->datum the-submodule-stx))
+    (define stxs-box
+      (hash-ref! submodule->stxs-box the-submodule-id
+                 (λ ()
+                   (when lift?
+                     (syntax-local-lift-module-end-declaration
+                      (quasisyntax/loc the-submodule-stx
+                        (define-module #,the-submodule-stx))))
+                   (box null))))
+    stxs-box))
+
+(define-syntax (slice stx)
+  (syntax-case stx ()
+    [(_ the-submodule e ...)
+     (identifier? #'the-submodule)
+     (begin
+       ;; This looks it up the first time and is allowed to create a
+       ;; list if necessary
+       (get-stxs-box #'the-submodule #t)
+       #'(begin-for-syntax
+           (define 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 stxs-box
+         (get-stxs-box #'the-submodule #f))
+       (quasisyntax/loc #'the-submodule
+         (module* the-submodule #f
+           #,@(unbox stxs-box))))]))
+
+(provide slice)

collects/racket/submodule.rkt

@@ -1,70 +0,0 @@
-#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/test.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
 @(require scribble/manual 
+          scribble/bnf
           "common.rkt" 
           (for-label racket/runtime-path
                      launcher/launcher))
@@ -9,4 +10,12 @@
 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.
+internal files that end in @filepath{.rkt} and inspects them as well.
+
+The @exec{raco test} command accepts a few flags:
+
+@itemize[
+ @item{@DFlag{s} @nonterm{id} or @DFlag{submodule} @nonterm{id}--- Requires the submodule @nonterm{id} rather than @racket['test].}
+
+ @item{@DFlag{r} or @DFlag{run-if-absent}--- Requires the default module if the given submodule is not present in a file.}
+]

collects/scribblings/reference/syntax.scrbl

@@ -11,7 +11,7 @@
                      racket/package
                      racket/splicing
                      racket/runtime-path
-                     racket/submodule
+                     racket/slice
                      racket/performance-hint))
 
 @(define require-eval (make-base-eval))
@@ -321,24 +321,22 @@ Legal only in a @tech{module begin context}, and handled by the
 
 
 @;------------------------------------------------------------------------
-@subsection[#:tag "submodule"]{Submodule helpers: @racket[module**]}
+@subsection[#:tag "slice"]{Slices: @racket[slice]}
 
-@note-lib-only[racket/submodule]
+@note-lib-only[racket/slice]
 
-@defform*[((module** id module-path form ...)
+@defform[(slice id form ...)]{
-           (module** id #f form ...))]{
 
-Like @racket[module*], but multiple occurrences of @racket[module**]
+Declares a @tech{slice} of a @tech{submodule} named @racket[id].
-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 ...)]{
+A @deftech{slice} is a piece of a @tech{submodule}. Each slice of a
-
+submodule is combined to form the entire submodule at
- An abbreviation of @racket[(module** test #f form ...)]; useful for
+the end of the enclosing module. If there is only one slice, then
- embedding tests while spreading them throughout your
+@racket[(slice id form ...)] is equivalent to @racket[(module* id #f
- modules. Cooperates with @exec{raco test}.
+form ...)]. It is an error for a submodule to be defined using
-}
+@racket[slice] @emph{and} @racket[module] or @racket[module*]. That
+is, if a submodule is made of slices, then it must be
+made @emph{only} of slices. }
 
 @;------------------------------------------------------------------------
 @section[#:tag '("require" "provide")]{Importing and Exporting: @racket[require] and @racket[provide]}

collects/tests/racket/slice.rkt

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

collects/tests/racket/submodule.rkt

@@ -1,52 +0,0 @@
-#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))