Allow users to filter tests using command-line arguments

rackunit-doc/rackunit/scribblings/filtering-tests.scrbl

@@ -0,0 +1,57 @@
+#lang scribble/manual
+
+@(require (for-label racket/base syntax/srcloc)
+          scribble/example)
+
+@(define e (make-base-eval '(require rackunit)))
+
+@title[#:tag "filtering-tests"]{Filtering Tests with Command-line Arguments}
+
+RackUnit supports test filtering so that one may run one test or a handful of
+tests out of a given set. This can be accomplished by using command-line
+arguments. Before each check is run, RackUnit will use the value of
+@racket[current-command-line-arguments] to construct a list of names, files,
+and lines to run.
+
+@examples[#:eval e
+          (parameterize ([current-command-line-arguments (vector "foo")])
+            (with-check-info (['name 'foo])
+              (check-equal? 1 2))
+            (check-equal? 2 3))]
+
+In the above example, the former test runs because its @racket['name] field
+matches with the value specified on the command line. The latter test is
+skipped.
+
+Multiple names can also be specified. Names are treated as regular expressions,
+and tests will be run if they match any of the names specified on the command
+line.
+
+@examples[#:eval e
+          (parameterize ([current-command-line-arguments (vector "foo" "bar")])
+            (with-check-info (['name 'foo])
+              (check-equal? 1 2))
+            (with-check-info (['name 'bar])
+              (check-equal? 2 3)))]
+
+Filtering by file or line number works similarly, and uses the syntax
+file:@italic{<file>} or line:@italic{<line>}.
+
+@examples[#:eval e
+          (parameterize ([current-command-line-arguments (vector "line:2")])
+            (check-equal? 1 2))]
+
+@examples[#:eval e
+          (parameterize ([current-command-line-arguments (vector "line:1")])
+            (check-equal? 2 3))]
+
+Name, file, and line specifiers can be combined to create more specific filters.
+
+@racketblock[(define loc (list (string->path "baz.rkt") 5 0 #f #f))
+          (parameterize ([current-command-line-arguments (vector "foo" "file:bar.rkt" "line:5")])
+            (with-check-info (['name 'foo]
+                              ['location (location-info loc)])
+              (check-equal? 1 2)))]
+
+The above example is not run because, even though the test name and line number
+are correct, the file names do not match.

rackunit-doc/rackunit/scribblings/rackunit.scrbl

@@ -15,6 +15,7 @@ from novices to experts.
 @include-section["quick-start.scrbl"]
 @include-section["philosophy.scrbl"]
 @include-section["api.scrbl"]
+@include-section["filtering-tests.scrbl"]
 @include-section["utils.scrbl"]
 @include-section["internals.scrbl"]
 @include-section["release-notes.scrbl"]

rackunit-lib/rackunit/private/check-info.rkt

@@ -17,6 +17,7 @@
   [info-value->string (-> any/c string?)]
   [check-info-mark symbol?]
   [check-info-stack (continuation-mark-set? . -> . (listof check-info?))]
+  [current-check-info (-> (listof check-info?))]
   [with-check-info* ((listof check-info?) (-> any) . -> . any)])
  with-check-info)
 
@@ -58,6 +59,10 @@
       (hash-set! ht (check-info-name x) (cons i x)))
     (map cdr (sort (hash-map ht (λ (k v) v)) < #:key car))))
 
+;; Shorthand to get the current check-info.
+(define (current-check-info)
+  (check-info-stack (current-continuation-marks)))
+
 ;; with-check-info* : (list-of check-info) thunk -> any
 (define (with-check-info* info thunk)
   (define current-marks

rackunit-lib/rackunit/private/check.rkt

@@ -97,6 +97,57 @@
                         (exn-continuation-marks exn)
                         (exn:test:check-stack exn))))
 
+(define (get-filters)
+  (for/fold ([names null] [files null] [lines null])
+            ([arg (vector->list (current-command-line-arguments))])
+    (cond
+      [(regexp-match-exact? #rx"[Ff][Ii][Ll][Ee]:.+" arg)
+       (define new-files (cons (regexp (substring arg 5)) files))
+       (values names new-files lines)]
+      [(regexp-match-exact? #rx"[Ll][Ii][Nn][Ee]:.+" arg)
+       (define line-num (string->number (substring arg 5)))
+       (define new-lines (if line-num (cons line-num lines) lines))
+       (values names files new-lines)]
+      [else (values (cons (regexp arg) names) files lines)])))
+
+(struct test-filter (names files lines))
+(define current-filters #f)
+(define last-cmd-args #f)
+
+(define (maybe-load-filters!)
+  (define cmd-args (current-command-line-arguments))
+  (unless (and current-filters (eq? last-cmd-args cmd-args))
+    (set! last-cmd-args cmd-args)
+    (define-values (new-names new-files new-lines) (get-filters))
+    (set! current-filters (test-filter new-names new-files new-lines)))
+  (void))
+
+(define (arguments-say-to-run)
+  (maybe-load-filters!)
+  (define names-to-run (test-filter-names current-filters))
+  (define files-to-run (test-filter-files current-filters))
+  (define lines-to-run (test-filter-lines current-filters))
+  (define name
+    (symbol->string
+     (check-info-value
+      (findf (lambda (info) (eq? (check-info-name info) 'name))
+             (current-check-info)))))
+  (define location
+    (location-info-value
+     (check-info-value
+      (findf (lambda (info) (eq? (check-info-name info) 'location))
+             (current-check-info)))))
+  (define file (if (path? (car location)) (path->string (car location)) ""))
+  (define line (cadr location))
+  (and (or (null? files-to-run)
+           (ormap (lambda (file-rex) (regexp-match? file-rex file))
+                  files-to-run))
+       (or (null? lines-to-run)
+           (ormap (lambda (ln) (equal? ln line)) lines-to-run))
+       (or (null? names-to-run)
+           (ormap (lambda (name-rex) (regexp-match? name-rex name))
+                  names-to-run))))
+
 (define-syntax (define-check stx)
   (syntax-case stx ()
     ((define-check (name formal ...) body ...)
@@ -113,14 +164,16 @@
                        ((current-check-around)
                         (lambda ()
                           (with-check-info*
-                           (list* (make-check-name (quote name))
-                                  (make-check-location location)
-                                  (make-check-expression expression)
-                                  (make-check-params (list formal ...))
-                                  (if message
-                                      (list (make-check-message message))
-                                      null))
-                             (lambda () (begin0 (let () body ...) (test-log! #t))))))
+                              (list* (make-check-name (quote name))
+                                     (make-check-location location)
+                                     (make-check-expression expression)
+                                     (make-check-params (list formal ...))
+                                     (if message
+                                         (list (make-check-message message))
+                                         null))
+                            (lambda ()
+                              (when (arguments-say-to-run)
+                                (begin0 (let () body ...) (test-log! #t)))))))
 
                        ;; All checks should return (void).
                        (void)))]

rackunit-test/tests/rackunit/arg-forwarding-test.rkt

@@ -0,0 +1,72 @@
+#lang racket/base
+
+(require rackunit
+         syntax/parse/define
+         racket/format
+         (for-syntax racket/base
+                     syntax/location))
+
+(define-syntax (current-file-name stx)
+  (with-syntax ([file (syntax-source-file-name stx)])
+    (syntax-case stx ()
+      [_ #'file])))
+
+(define-syntax (current-line-number stx)
+  (with-syntax ([line (syntax-line stx)])
+    (syntax-case stx ()
+      [_ #'line])))
+
+(define-simple-macro (with-cmd (args ...) e)
+  (parameterize ([current-command-line-arguments (vector args ...)])
+    (let () e)))
+
+(define-simple-macro (run-test (args ...) e)
+  (with-cmd (args ...)
+    (let ([result (open-output-string)])
+      (parameterize ([current-error-port result])
+        (begin e (get-output-string result))))))
+
+(define-simple-macro (check-error (args ...) e)
+  (when (zero? (string-length (run-test (args ...) e)))
+    (eprintf "TEST FAILED: (check-error ~s ~a)\n"
+             (map ~a (list args ...)) (quote e))))
+
+(define-simple-macro (check-no-error (args ...) e)
+  (let ([result (run-test (args ...) e)])
+    (unless (zero? (string-length result))
+      (eprintf "TEST FAILED: (check-no-error ~s ~a)\n~a\n"
+               (map ~a (list args ...)) (quote e) result))))
+
+(define FILE-NAME (path->string (current-file-name)))
+
+(module+ test
+  ;; Define args for correct and incorrect file names.
+  (define file-name-arg (format "file:~a" FILE-NAME))
+  (define wrong-file-name-arg
+    (format "file:~a"
+            (list->string (map (compose integer->char add1 char->integer)
+                               (string->list FILE-NAME)))))
+  ;; Define test.
+  (define (go)
+    (with-check-info (['name 'foo])
+      (check-equal? 1 2))) (define GO-LINE (current-line-number)) ;; Keep this on same line!
+  ;; Define args for correct and incorrect line numbers.
+  (define go-line-num-arg (format "line:~a" GO-LINE))
+  (define wrong-go-line-num-arg (format "line:~a" (+ GO-LINE 100)))
+
+  (check-error ("foo") (go))
+  (check-no-error ("baz") (go))
+  (check-error ("foo" "baz") (go))
+  (check-error ("foo" file-name-arg) (go))
+  (check-error ("foo" go-line-num-arg) (go))
+  (check-no-error ("foo" wrong-file-name-arg) (go))
+  (check-no-error ("foo" wrong-go-line-num-arg) (go))
+  (check-no-error ("foo" file-name-arg wrong-go-line-num-arg) (go))
+  (check-no-error ("foo" wrong-file-name-arg go-line-num-arg) (go))
+
+  (define (go2)
+    (check-equal? 2 3))
+
+  (check-error () (go2))
+  (check-no-error ("foo") (go2))
+  )