#lang racket/base
;;; @Package  Overeasy
;;; @Subtitle Racket Language Test Engine
;;; @HomePage http://www.neilvandyke.org/overeasy/
;;; @Author   Neil Van Dyke
;;; @Version  0.1
;;; @Date     2011-08-26
;;; @PLaneT   neil/overeasy:1:=0

;; $Id: overeasy.rkt,v 1.52 2011/08/27 00:24:58 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2011 Neil Van Dyke.  This program is Free Software;
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 3 of the License (LGPL 3), or (at your option)
;;; any later version.  This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

(require (for-syntax racket/base
                     syntax/parse)
         racket/port)

;;; @section Introduction

;;; Overeasy is a software test engine for the Racket programming language.  It
;;; designed for all of:
;;;
;;; @itemize
;;; @item rapid interactive testing of expressions in the REPL;
;;; @item unit testing of individual modules; and
;;; @item running hierarchical sets of individual module unit tests at once.
;;; @end itemize
;;;
;;; An individual test case, or @i{test}, is specified by the programmer with
;;; the @i{test} syntax, and evaluation of that syntax causes the test to be
;;; run.  Properties that are checked by tests are:
;;;
;;; @itemize
;;; @item values of expressions (single value, or multiple value);
;;; @item exceptions raised; and
;;; @item output to @code{current-output-port} and @code{current-error-port}.
;;; @end itemize
;;;
;;; Some checking is also done to help protect test suites from crashing due to
;;; errors in the setup of the test itself, such as errors in evaluating an
;;; expression that provides an expected value for a test.
;;;
;;; A future version of Overeasy might permit the properties that are
;;; tested to be extensible, such as for testing network state or other
;;; resources.
;;;
;;; For the properties checked by tests, in most cases, the programmer can
;;; specify both an expected value and a predicate, or @i{checker}, for
;;; comparing expected and actual values.  Note that, if the predicate is not
;;; an equality predicate of some kind, then the ``expected'' would be a
;;; misnomer, and ``argument to the predicate'' would be more accurate.  The
;;; actual @code{test} syntax does not include the word ``expected.''
;;; Specification of expected exceptions is diferent from values and output
;;; ports, in that only the predicate is specified, with no separate expected
;;; or argument value.  All these have have reasonable defaults whenever
;;; possible.

;;; @subsection Examples
;;;
;;; Here's a simple test, with the first argument the expression under test, and
;;; the other argument the expected value.
;;;
;;; @lisp
;;; (test (+ 1 2 3) 6)
;;; @end lisp
;;;
;;; How the results of tests are reported varies depending on how the tests are
;;; run.  For purposes of these examples, we will pretend we are running tests in
;;; the simplest way.  In this way, tests that fail produce one-line error-messages
;;; to @code{current-error-port}, which in DrRacket show up as red italic text by
;;; default.  Tests that pass in this way do not produce any message at all.  So,
;;; our first example above, does not produce any message.
;;;
;;; Now, for a test that fails:
;;;
;;; @lisp
;;; (test (+ 1 2 3) 7)
;;; @end lisp
;;; @example
;;;     Test FAIL : Value 6 did not match expected value 7 by equal?.
;;; @end example
;;;
;;; That's a quick way to do a test in a REPL or when you're otherwise in a
;;; hurry, but if you're reviewing a report of failed tests for one or more
;;; modules, you'd probably like a more descriptive way of seeing which tests
;;; failed.  That's what the @i{test ID} is for, and to specify it, we have to
;;; give keyword arguments in our @code{test}:
;;;
;;; @lisp
;;; (test (+ 1 2 3)
;;;       7
;;;       #:id 'simple-addition)
;;; @end lisp
;;; @example
;;;     Test FAIL simple-addition : Value 6 did not match expected value 7 by equal?.
;;; @end example
;;;
;;; Quick note on syntax.  The above is actually shorthand syntax.  In the
;;; non-shorthand syntax, every argument to @code{test} has a keyword, so the
;;; above is actually shorthand for:
;;;
;;; @lisp
;;; (test #:code (+ 1 2 3)
;;;       #:val  7
;;;       #:id   'simple-addition)
;;; @end lisp
;;;
;;; @code{#:code} and @code{#:val} are used so often that the keywords can be
;;; left off, so long as the values are positionally the first and second
;;; arguments of @code{test}.  One reason you might want to use the
;;; non-shorthand is if you like to have an ID for each test and you like to
;;; have @code{#:id} as the first thing, like a label or heading:
;;;
;;; @lisp
;;; (test #:id   'simple-addition
;;;       #:code (+ 1 2 3)
;;;       #:val  7)
;;; @end lisp
;;;
;;; In the rest of these examples, we'll use the shorthand syntax, because it's
;;; quicker to type, and getting rid of the @code{#:code} and @code{#:val}
;;; keywords also makes less-common keyword arguments stand out.
;;;
;;; So far, we've been checking the values of code, and we haven't yet dealt in
;;; exceptions.  Exceptions, such as due to programming errors in the code
;;; being tested, can also be reported:
;;;
;;; @lisp
;;; (test (+ 1 (error "help!") 3)
;;;       3)
;;; @end lisp
;;; @example
;;;     Test FAIL : Got exception #(struct:exn:fail "help!"), but expected value 3.
;;; @end example
;;;
;;; And if an exception is the correct behavior, instead of specifying an expected value, we
;;; can use @code{#:exn} to specify predicate just like for @code{with-handlers}:
;;;
;;; @lisp
;;; (test (+ 1 (error "help!") 3)
;;;       #:exn exn:fail?)
;;; @end lisp
;;;
;;; That test passed.  But if our code under test doesn't throw an exception
;;; matched by our @code{#:exn} predicate, that's a test failure:
;;;
;;; @lisp
;;; (test (+ 1 2 3)
;;;       #:exn exn:fail?)
;;; @end lisp
;;; @example
;;;     Test FAIL : Got value 6, but expected exception matched by predicate exn:fail?.
;;; @end example
;;;
;;; Of course, when you want finer discrimination of exceptions than, say,
;;; @code{exn:fail?} or @code{exn:fail:filesystem?}, you can write a custom
;;; predicate that uses @code{exn-message} or other information, and supply it
;;; to @code{test}'s @code{#:exn}.
;;;
;;; Multiple values are supported:
;;;
;;; @lisp
;;; (test (begin 1 2 3)
;;;       (values 1 2 3))
;;; @end lisp
;;; @example
;;;     Test FAIL : Value 3 did not match expected values (1 2 3) by equal?.
;;; @end example
;;;
;;; You might have noticed that a lot of the test failure messages say ``by
;;; equal?''.  That's referring to the default predicate, so, the following
;;; test passes:
;;;
;;; @lisp
;;; (test (string-append "a" "b" "c")
;;;       "abc")
;;; @end lisp
;;;
;;; But we let's say we wanted the expected and actual values to not only be
;;; @code{equal?} but to be @code{eq?} as well:
;;;
;;; @lisp
;;; (test (string-append "a" "b" "c")
;;;       "abc"
;;;       #:val-check eq?)
;;; @end lisp
;;; @example
;;;     Test FAIL : Value "abc" did not match expected value "abc" by eq?.
;;; @end example
;;;
;;; As mentioned earlier, the checker does not have to be an equality
;;; predicate, and it can use whatever reasoning you like in rendering is
;;; verdict on whether the actual value should be considered OK.
;;;
;;; In addition to values an exceptions, @code{test} also intercepts and
;;; permits checking of @code{current-output-port} and
;;; @code{current-error-port}.  By default, it assumes no output to either of
;;; those ports, which is especially good for catching programming errors like
;;; neglecting to specify an output port to a procedure for which the port is
;;; optional:
;;;
;;; @lisp
;;; (test (let ((o (open-output-string)))
;;;         (display 'a o) (display 'b) (display 'c o)
;;;         (get-output-string o))
;;;       "abc")
;;; @end lisp
;;; @example
;;;     Test FAIL : Value "ac" did not match expected value "abc" by equal?. Out bytes #"b" did not match expected #"" by equal?.
;;; @end example
;;;
;;; Likewise, messages to @code{current-error-port}, such as warnings and
;;; errors from legacy code, are also caught by default:
;;;
;;; @lisp
;;; (test (begin (fprintf (current-error-port)
;;;                       "%W%SYS$FROBINATOR_OVERHEAT\n")
;;;              0)
;;;       42)
;;; @end lisp
;;; @example
;;;     Test FAIL : Value 0 did not match expected value 42 by equal?. Err bytes #"%W%SYS$FROBINATOR_OVERHEAT\n" did not match expected #"" by equal?.
;;; @end example
;;;
;;; Now we know why we've started getting 0, which information might have gone
;;; unnoticed had our test engine not captured error port output: the
;;; frobinator is failing, after all these years of valiant service.
;;;
;;; With the @code{#:out-check} and @code{#:err-check} keyword arguments to
;;; @code{test}, you can specify predicates other than @code{equal?}.  Also, by
;;; setting one of these predicates to @code{#f}, you can cause the output to
;;; be consumed but not stored and checked.  This is useful if, for example,
;;; the code produces large amounts of debugging message output.
;;;
;;; @lisp
;;; (test (begin (display "blah")
;;;              (display "blah")
;;;              (display "blah")
;;;              (* 44 2))
;;;       88
;;;       #:out-check #f)
;;; @end lisp
;;;
;;; There are some more tricks you can do with @code{test}.  Most notably,
;;; you'll sometimes want to set up state in the system -- Racket parameters,
;;; test input files, whatever.  Because the @code{test} syntax can appear
;;; anywhere normal Racket code can, you can set up this state using normal
;;; Racket code.  No special forms for setup and tear-down are required, nor
;;; are they provided.
;;;
;;; @subsection Report Backends
;;;
;;; The architecture of Overeasy is designed to permit different backends
;;; for reporting test results to be plugged in.  Currently implemented backends
;;; are for:
;;;
;;; @itemize
;;; @item quick one-line error messages for tests that fail; and
;;; @item more verbose textual report of all test cases run.
;;; @end itemize
;;;
;;; @noindent
;;; In the future, Web front-end and GUI backends might also be implemented.
;;; The backend is dynamic context, so no changes to the files containing test
;;; code is required to run the tests with a different backend.
;;;
;;; @subsection Test Contexts and Test Sections
;;;
;;; The architectural notion that permits the backends to be plugged in is
;;; called the @i{test context}.  Test context are nested dynamically, with
;;; each introduced context having the previous context as a parent.  The same
;;; test context notion that permits backends for reporting to be introduced
;;; also permits @i{test sections} for grouping tests to be nested dynamically.
;;; The dynamic nesting of test sections facilitates reporting of test results
;;; when running unit tests for multiple modules together.  Plugging in a
;;; backend for reporting simply means establishing it as the first or topmost
;;; test context.
;;;
;;; By default, if a test is run without a test context, then the one-line
;;; error messages are used.  If a test section context is introduced without a
;;; parent context, such as would usually be the case for an individual
;;; module's unit tests, then the text report backend is plugged in by default.
;;;
;;; One place you'll want to use a section is for the unit tests for a
;;; particular module.  This groups the tests together if the module's unit
;;; tests are run in the context of a larger test suite, and it also provides a
;;; default report context when the unit tests are run by themselves.  You
;;; might want to package the module's unit tests in a procedure, for ease of
;;; use as part of a test suite.  (Unless you have rigged up something
;;; different, like by having @code{require} or @code{dynamic-require} simply
;;; run the tests, without needing to then invoke a provided procedure.  For
;;; illustration in this document, we'll use procedures.)  For example, if you
;;; have a @code{fruits} module, in file @code{fruits.rkt}, then you might want
;;; to put its unit tests in a procedure in file @code{test-fruits.rkt}, like
;;; so:
;;;
;;; @lisp
;;; (define (test-fruits)
;;;   (with-test-section
;;;    #:id 'fruits
;;;    (test #:id 'apple  #:code (+ 1 2 3) #:val 6)
;;;    (test #:id 'banana #:code (+ 4 5 6) #:val 6)
;;;    (test #:id 'cherry #:code (+ 7 8 9) #:val 24)))
;;; @end lisp
;;;
;;; Notice that we put all the tests for module in @code{fruits} in
;;; @code{with-test-section} here, and gave it an ID.  The ID didn't have to be
;;; @code{fruits} like the module name; we could have called it
;;; @code{fruity-unit-tests}, @code{fructose}, or any other symbol.
;;;
;;; Then let's say we have a @code{cars} module, so in file @code{some-cars-tests.rkt}, we put
;;; this procedure:
;;;
;;; @lisp
;;; (define (test-drive-cars)
;;;   (with-test-section
;;;    #:id 'cars
;;;    (test (+ 77 11) 88 #:id 'delorean)
;;;    (test (or (and #f 'i-cant-drive) 55) 55 #:id 'ferrari)
;;;    (test (+ 300 8) 308 #:id 'magnum)))
;;; @end lisp
;;;
;;; Those unit test suites are used independently.  Later, those modules are
;;; integrated into a larger system, COLOSSUS.  For running all the unit tests
;;; for the modules of COLOSSUS, we add another module, which @code{require}s
;;; the other test modules, and invokes the each unit test procedure within its
;;; own test section:
;;;
;;; @lisp
;;; (with-test-section
;;;  #:id 'colossus-components
;;;  (test-fruits)
;;;  (test-drive-cars))
;;; @end lisp
;;;
;;; Unless this is done within another test context, the result will be to
;;; execute the tests in the default text report context.  This produces a
;;; report like:
;;;
;;; @smallexample
;;; ;; START-TESTS
;;; ;;
;;; ;; START-TEST-SECTION colossus-components
;;; ;;
;;; ;; START-TEST-SECTION fruits
;;; ;;
;;; ;; TEST apple
;;; ;; (+ 1 2 3)
;;; ;; OK
;;; ;;
;;; ;; TEST banana
;;; ;; (+ 4 5 6)
;;; ;; *FAIL* Value 15 did not match expected value 6 by equal?.
;;; ;;
;;; ;; TEST cherry
;;; ;; (+ 7 8 9)
;;; ;; OK
;;; ;;
;;; ;; END-TEST-SECTION fruits
;;; ;;
;;; ;; START-TEST-SECTION cars
;;; ;;
;;; ;; TEST delorean
;;; ;; (+ 77 11)
;;; ;; OK
;;; ;;
;;; ;; TEST ferrari
;;; ;; (or (and #f (quote i-cant-drive)) 55)
;;; ;; OK
;;; ;;
;;; ;; TEST magnum
;;; ;; (+ 300 8)
;;; ;; OK
;;; ;;
;;; ;; END-TEST-SECTION cars
;;; ;;
;;; ;; END-TEST-SECTION colossus-components
;;; ;;
;;; ;; END-TESTS
;;; ;;     OK: 5  FAIL: 1  BROKEN: 0
;;; ;;     SOME TESTS *FAILED*!
;;; @end smallexample
;;;
;;; The test sections here are nested only two deep, but test sections may be
;;; nested to arbitrary depth.  You can use test sections at each nested
;;; subsystem, to organize the unit tests for a module into groups, to group
;;; variations of generated test cases (e.g., if evaluating the same
;;; @code{test} form multiple times, with different values or state each time),
;;; or other purposes.
;;;
;;; @subsection Project Status and History
;;;
;;; Work is ongoing, but Overeasy should be useful already.  It is being
;;; developed both as a useful tool, and as input to discussion in the Racket
;;; developer community about unifying the various test engines.
;;;
;;; This package does not yet provide an interface so that additional reporting
;;; backends can be added.  This is intentional, so that we can be comfortable
;;; that the interface won't be changing soon before others start developing to
;;; it.

;; TODO: Discuss related projects, including RackUnit, eli-tester, and DrDr.

;;; As a historical note, Overeasy is much superior to the author's 2005
;;; lightweight unit testing library,
;;; @uref{http://www.neilvandyke.org/testeez/, Testeez}.

;;; @section Interface

;; @section Test Specs

;; TODO: Maybe rename "spec" to "decl" or "defn" or something, to avoid
;; confusion with software test specification documents.

(define (%test-spec-custom-write spec out mode)
  (fprintf out "#<test-spec:~S>" (test-spec-id spec)))

(define-struct test-spec
  ;; TODO: Maybe code-sexp should be code-stx?
  ;;
  ;; TODO: add value-sexp and exception-sexp?
  ;;
  ;; TODO: Include stx of the "test" form?
  (id
   code-sexp
   code-thunk
   expected-exn
   expected-vals
   vals-check
   expected-out
   expected-err
   out-check
   err-check
   notes)
  #:property prop:custom-write %test-spec-custom-write)

(define-syntax %make-test-spec/kw
  (syntax-rules ()
    ((_ #:id            id
        #:code-sexp     code-sexp
        #:code-thunk    code-thunk
        #:expected-exn  expected-exn
        #:expected-vals expected-vals
        #:vals-check    vals-check
        #:expected-out  expected-out
        #:expected-err  expected-err
        #:out-check     out-check
        #:err-check     err-check
        #:notes         notes)
     (make-test-spec id
                     code-sexp
                     code-thunk
                     expected-exn
                     expected-vals
                     vals-check
                     expected-out
                     expected-err
                     out-check
                     err-check
                     notes))))

;; @section Test Results

(define-struct test-result
  (spec
   actual-exn
   actual-vals
   actual-out
   actual-err
   exn-ok?
   vals-ok?
   out-ok?
   err-ok?
   ok?))

(define (%make-test-result/kw
         #:spec        spec
         #:actual-exn  actual-exn
         #:actual-vals actual-vals
         #:actual-out  actual-out
         #:actual-err  actual-err
         #:exn-ok?     exn-ok?
         #:vals-ok?    vals-ok?
         #:out-ok?     out-ok?
         #:err-ok?     err-ok?
         #:ok?         ok?)
  (make-test-result spec
                    actual-exn
                    actual-vals
                    actual-out
                    actual-err
                    exn-ok?
                    vals-ok?
                    out-ok?
                    err-ok?
                    ok?))

(define (%write-test-result-textual-problem-summary result out)
  (let* ((spec         (test-result-spec       result))
         (expected-exn (test-spec-expected-exn spec))
         (actual-exn   (test-result-actual-exn result)))
    (if expected-exn
        (or (test-result-exn-ok? result)
            (if actual-exn
                (fprintf out
                         " Exception ~A was not matched by expected exception predicate ~A."
                         (%pretty-exn-string actual-exn)
                         (%pretty-proc-name-string expected-exn))
                (fprintf out
                         " Got ~A, but expected exception matched by predicate ~A."
                         (%pretty-vals (test-result-actual-vals result))
                         (%pretty-proc-name-string expected-exn))))
        (or (test-result-vals-ok? result)
            (let ((expected-vals (test-spec-expected-vals spec)))
              (if actual-exn
                  (fprintf out
                           " Got exception ~A, but expected ~A."
                           (%pretty-exn-string actual-exn)
                           (%pretty-vals expected-vals))
                  (fprintf out
                           " ~A did not match expected ~A by ~A."
                           (%pretty-vals (test-result-actual-vals result)
                                         #:capitalized? #t)
                           (%pretty-vals expected-vals)
                           (%pretty-proc-name-string
                            (test-spec-vals-check spec)))))))
    (let-syntax
        ((do-err/out
          (syntax-rules ()
            ((_ STR SPEC-CHECK RESULT-OK? RESULT-ACTUAL SPEC-EXPECTED)
             (cond ((SPEC-CHECK spec)
                    => (lambda (check)
                         (or (RESULT-OK? result)
                             (fprintf out
                                      " ~A bytes ~S did not match expected ~S by ~A."
                                      STR
                                      (RESULT-ACTUAL result)
                                      (SPEC-EXPECTED spec)
                                      (%pretty-proc-name-string check))))))))))
      (do-err/out "Out"
                  test-spec-out-check
                  test-result-out-ok?
                  test-result-actual-out
                  test-spec-expected-out)
      (do-err/out "Err"
                  test-spec-err-check
                  test-result-err-ok?
                  test-result-actual-err
                  test-spec-expected-err))))

;; @section Test Contexts

(define-struct test-context
  (parent
   id
   handle-start
   handle-end
   handle-child-start
   handle-child-end
   handle-test-start
   handle-test-end
   handle-test-broken))

(define (make-test-context/kw #:parent             parent
                              #:id                 id
                              #:handle-start       handle-start
                              #:handle-end         handle-end
                              #:handle-child-start handle-child-start
                              #:handle-child-end   handle-child-end
                              #:handle-test-start  handle-test-start
                              #:handle-test-end    handle-test-end
                              #:handle-test-broken handle-test-broken)
  (make-test-context parent
                     id
                     handle-start
                     handle-end
                     handle-child-start
                     handle-child-end
                     handle-test-start
                     handle-test-end
                     handle-test-broken))

(define %current-test-context (make-parameter #f))

(define (%start-test-context construct-from-parent)
  (let* ((parent-context (%current-test-context))
         (new-context    (construct-from-parent parent-context)))
    (and parent-context
         ((test-context-handle-child-start parent-context) new-context))
    ((test-context-handle-start new-context))
    (%current-test-context new-context)))

(define (%end-test-context)
  (let* ((old-context    (or (%current-test-context)
                             (error '%end-test-context
                                    "no current test context")))
         (parent-context (test-context-parent old-context)))
    ((test-context-handle-end old-context))
    (and parent-context
         ((test-context-handle-child-end parent-context) old-context))
    (%current-test-context parent-context)))

(define-syntax %with-test-context/construct-from-parent
  (syntax-rules ()
    ((_ CONSTRUCT-FROM-PARENT BODY0 BODYn ...)
     (dynamic-wind
       (lambda ()
         (%start-test-context CONSTRUCT-FROM-PARENT))
       (lambda ()
         BODY0 BODYn ...)
       (lambda ()
         (%end-test-context))))))

;; @subsection Text Test Context

(define (make-text-report-context parent)
  (let ((out          (current-output-port))
        (ok-count     0)
        (fail-count   0)
        (broken-count 0))
    (make-test-context/kw
     #:parent
     (and parent
          (error 'make-text-report-context
                 "unexpected parent ~S"
                 parent))
     #:id
     '<text-report>
     #:handle-start
     (lambda ()
       (fprintf out "\n;; START-TESTS\n"))
     #:handle-end
     (lambda ()
       (fprintf out ";;\n;; END-TESTS\n")
       (fprintf out
                ";;     OK: ~S  FAIL: ~S  BROKEN: ~S\n"
                ok-count
                fail-count
                broken-count)
       (fprintf out
                ";;     ~A!\n\n"
                (cond ((zero? (+ ok-count fail-count broken-count))
                       "*NO TESTS*")
                      ((not (zero? broken-count)) "SOME TESTS *BROKEN*")
                      ((zero? fail-count)         "ALL TESTS *PASSED*")
                      ((zero? ok-count)           "ALL TESTS *FAILED*")
                      (else                       "SOME TESTS *FAILED*"))))
     #:handle-child-start
     (lambda (child-context)
       (fprintf out
                ";;\n;; START-TEST-SECTION ~S\n"
                (test-context-id child-context)))
     #:handle-child-end
     (lambda (child-context)
       (fprintf out
                ";;\n;; END-TEST-SECTION ~S\n"
                (test-context-id child-context)))
     #:handle-test-start
     void
     #:handle-test-end
     (lambda (result)
       (let ((spec (test-result-spec result)))
         (fprintf out
                  ";;\n;; TEST ~S\n;; ~S\n;; ~A\n"
                  (or (test-spec-id spec) '<unspecified-id>)
                  (test-spec-code-sexp spec)
                  ;; TODO: Show actual returned values, exceptions, outputs,
                  ;; and annotate those when differ from expected.
                  (if (test-result-ok? result)
                      (begin (set! ok-count (+ 1 ok-count))
                             "OK")
                      (let ((os (open-output-string)))
                        (set! fail-count (+ 1 fail-count))
                        (display "*FAIL*" os)
                        (%write-test-result-textual-problem-summary result os)
                        (get-output-string os))))))
     #:handle-test-broken
     (lambda (exn)
       (set! broken-count (+ 1 broken-count))
       (fprintf out
                "TEST BROKEN!~A\n"
                (%space-value-if-true
                 (%test-setup-exn-id exn))
                (exn-message exn))))))

;; @subsection Single Test Context

(define (%space-value-if-true val)
  (if val
      (format " ~A" val)
      ""))

(define (%pretty-proc-name-string proc)
  (let ((name (cond ((object-name proc) => symbol->string)
                    (else
                     (let ((name (call-with-output-string
                                  (lambda (out)
                                    (write proc out)))))
                       (cond ((regexp-match #rx"^#<procedure:(.*)>$" name)
                              => cadr)
                             (else name)))))))
    (cond ((regexp-match-positions #rx"\\.(?:rkt|ss|scm):[0-9]+:[0-9]$" name)
           => (lambda (m)
                (string-append "#<procedure:" name ">")))
          (else name))))

(define (%pretty-exn-string exn)
  (let ((str (format "~S" exn)))
    (cond ((regexp-match "^(#\\(struct:.*) #<continuation-mark-set>\\)$"
                         str)
           => (lambda (m)
                (string-append (cadr m) ")")))
          (else str))))

(define (%pretty-vals vals #:capitalized? (capitalized? #f))
  (let ((first-letter (if capitalized? "V" "v")))
    (if (null? (cdr vals))
        (format "~Aalue ~S"  first-letter (car vals))
        (format "~Aalues ~S" first-letter vals))))

(define (make-single-test-context parent)
  (let ((out (current-error-port)))
    (make-test-context/kw
     #:parent
     parent
     #:id
     '<single-test>
     #:handle-start
     void
     #:handle-end
     void
     #:handle-child-start
     (lambda (child-context)
       (error '<make-single-test-context>
              "handle-child-start called"))
     #:handle-child-end
     (lambda (child-context)
       (error '<make-single-test-context>
              "handle-child-end called"))
     #:handle-test-start
     void
     #:handle-test-end
     (lambda (result)
       (or (test-result-ok? result)
           (let ((os   (open-output-string))
                 (spec (test-result-spec result)))
             (display "Test FAIL" os)
             (cond ((test-spec-id spec)
                    => (lambda (id)
                         (write-char #\space os)
                         (display id os))))
             (display " :" os)
             (%write-test-result-textual-problem-summary result os)
             (displayln (get-output-string os) out))))
     #:handle-test-broken
     (lambda (exn)
       (fprintf out
                "TEST BROKEN!~A\n"
                (%space-value-if-true
                 (%test-setup-exn-id exn))
                (exn-message exn))))))

;; @subsection Section Test Context

(define %current-default-parent-test-context-for-sections (make-parameter #f))

;; TODO: THIS CONTEXT STUFF IS A LITTLE MESSY.  SIMPLIFY.  Maybe part of this
;; is making default behavior for the handlers to be to propagate (value symbol
;; "propagate-to-parent" or "default" instead of a proc.

;;; @defsyntax with-test-section #:id id body ...
;;;
;;; See above.

(define-syntax with-test-section
  (syntax-rules ()
    ((_ #:id ID BODYn ...)
     (let ((id ID))
       (%call-with-current-test-context-or-construct
        (%current-default-parent-test-context-for-sections)
        (lambda (parent)
          (%with-test-context/construct-from-parent
           (lambda (parent)
             ;; TODO: !!! CHANGE ALL THESE KEYWORD ARGS FOR SECTIONS !!!!!!!!!!!!!!!!!!!!!!!
             (let ((this-context
                    (make-test-context/kw
                     #:parent             parent
                     #:id                 id
                     #:handle-start       void ;; !!!
                     #:handle-end         void ;; !!!
                     #:handle-child-start (lambda (child-context)
                                            ((test-context-handle-child-start parent) child-context))
                     #:handle-child-end   (lambda (child-context)
                                            ((test-context-handle-child-end parent) child-context))
                     #:handle-test-start  (lambda (spec)
                                            ((test-context-handle-test-start parent) spec))
                     #:handle-test-end    (lambda (result)
                                            ((test-context-handle-test-end parent) result))
                     #:handle-test-broken (lambda (exn)
                                            ((test-context-handle-test-broken parent) exn)))))
               this-context))
           BODYn ...)))))))

;; TODO: Is this safe?
(%current-default-parent-test-context-for-sections make-text-report-context)

;;
;; (define (start-test-section #:id    (id    #f)
;;                             #:notes (notes #f))
;;   (let* ((parent-context (or (%current-test-context)
;;                              ((%current-default-parent-test-context-for-sections) #f)))
;;          (new-context    (make-test-context parent-context
;;                                             id
;;                                             notes))
;;          (start-handler '!!!)
;;
;;          (
;;
;;           '!!!
;;           )
;;          (make-test-context/kw #:parent parent
;;                                #:handle-start handle-start
;;                                #:handle-end  handle-end
;;
;;                                #:handle-child-start handle-child-start
;;                                #:handle-child-end handle-child-end
;;                                #:handle-test-start handle-test-start
;;                                #:handle-test-end handle-test-end)
;;
;;
;;          !!!
;;          )))

;; @section Tests

(define %current-default-test-context-maker-for-tests (make-parameter #f))

(%current-default-test-context-maker-for-tests make-single-test-context)

(define-struct (%test-setup-exn exn:fail)
  (id))

(define-syntax %test-setup-values
  (syntax-rules ()
    ;; TODO: Can put the WHAT-STRING in at syntax expansion time.
    ((_ ID WHAT-STRING EXPR)
     (with-handlers
         ((exn:fail?
           (lambda (orig-exn)
             (raise (make-%test-setup-exn
                     (format "Exception from ~A during test setup: ~S"
                             WHAT-STRING
                             (exn-message orig-exn))
                     (exn-continuation-marks orig-exn)
                     ID)))))
       EXPR))))

;; TODO: !!! make %test-setup-value/proc and use it for "expected-exn" and for
;; some of the checkers.  And "/proc-or-false" for out/err checkers.

(define-syntax %test-setup-value/non-false
  (syntax-rules ()
    ((_ ID WHAT-STRING EXPR)
     ;; TODO: Can put the WHAT-STRING in at syntax expansion time.
     ;;
     ;; TODO: Error-check that it's not multiple-value.
     (or (%test-setup-values ID WHAT-STRING EXPR)
         (raise (make-%test-setup-exn
                 (format "Invalid ~A during test setup: #f"
                         WHAT-STRING)
                 (current-continuation-marks)
                 ID))))))

;; TODO: When writing "code-sexp", normalize the writing procedure.

;; (define (%finish-executing-test-spec-after-eval #:spec spec
;;         #:actual-exn actual-exn
;;         #:actual-value     actual-value)
;;
;;  )

(define (%false x)
  #f)

(define (%open-output-null)
  ;; Note: This definition is taken from the Racket 5.1.2 documentation for
  ;; "make-output-port".
  (make-output-port
   'null
   always-evt
   (lambda (s start end non-block? breakable?) (- end start))
   void
   (lambda (special non-block? breakable?) #t)
   (lambda (s start end) (wrap-evt always-evt (lambda (x) (- end start))))
   (lambda (special) always-evt)))

(define (%call-with-current-test-context-or-single proc)
  (cond ((%current-test-context) => proc)
        (else (%with-test-context/construct-from-parent
               make-single-test-context
               (proc (%current-test-context))))))

(define (%call-with-current-test-context-or-construct construct proc)
  (cond ((%current-test-context) => proc)
        (else (%with-test-context/construct-from-parent
               construct
               (proc (%current-test-context))))))

;; (define-struct %not-applicable ())
;; (define %not-applicable (make-%not-applicable))

(define (%execute-test-spec spec)
  (%call-with-current-test-context-or-single
   (lambda (context)
     ((test-context-handle-test-start context) spec)
     (let* ((out-check (test-spec-out-check spec))
            (err-check (test-spec-err-check spec))
            (out-op    (if out-check (open-output-bytes) (%open-output-null)))
            (err-op    (if err-check (open-output-bytes) (%open-output-null))))
       (parameterize ((current-output-port out-op)
                      (current-error-port  err-op))
         (let*-values
             (((expected-exn)
               (test-spec-expected-exn spec))
              ((actual-exn actual-vals exn-ok? vals-ok?)
               (with-handlers (((or expected-exn %false)
                                (lambda (actual-exn)
                                  (values actual-exn
                                          'not-applicable
                                          #t
                                          'not-applicable)))
                               (exn:fail?
                                (lambda (actual-exn)
                                  (values actual-exn
                                          'not-applicable
                                          #f ; TODO: not-applicable?
                                          #f))))
                 (let ((actual-vals (call-with-values
                                        (test-spec-code-thunk spec)
                                      list)))
                   (if expected-exn
                       (values #f
                               actual-vals
                               #f
                               'not-applicable)
                       (let ((expected-vals  (test-spec-expected-vals spec)))
                         (values #f
                                 actual-vals
                                 'not-applicable
                                 ((test-spec-vals-check spec)
                                  actual-vals
                                  expected-vals)))))))
              ;; TODO: Make a macro for output ports.
              ((actual-out out-ok?)
               (if out-check
                   (let ((actual-bytes (get-output-bytes out-op)))
                     (values actual-bytes
                             (out-check actual-bytes
                                        (test-spec-expected-out spec))))
                   (values 'not-applicable
                           'not-applicable)))
              ((actual-err err-ok?)
               (if err-check
                   (let ((actual-bytes (get-output-bytes err-op)))
                     (values actual-bytes
                             (err-check actual-bytes
                                        (test-spec-expected-err spec))))
                   (values 'not-applicable
                           'not-applicable)))
              ((ok?)
               (and (if expected-exn
                        exn-ok?
                        vals-ok?)
                    (or (not out-check) out-ok?)
                    (or (not err-check) err-ok?)
                    #t))
              ((result)
               (%make-test-result/kw #:spec        spec
                                     #:actual-exn  actual-exn
                                     #:actual-vals actual-vals
                                     #:actual-out  actual-out
                                     #:actual-err  actual-err
                                     #:exn-ok?     exn-ok?
                                     #:vals-ok?    vals-ok?
                                     #:out-ok?     out-ok?
                                     #:err-ok?     err-ok?
                                     #:ok?         ok?)))
           ((test-context-handle-test-end context) result)
           (void)))))))

(define (make-exn-with-message-predicate pred msg)
  (let ((<make-exn-with-message-predicate>
         (lambda (e)
           (and (pred e)
                (equal? (exn-message e) msg)))))
    <make-exn-with-message-predicate>))

(define (make-exn-with-message-starts-with-predicate pred msg)
  (let ((rx (string-append "^" (regexp-quote msg))))
    (let ((<make-exn-with-message-starts-with-predicate>
           (lambda (e)
             (and (pred e)
                  (regexp-match? rx (exn-message e))))))
      <make-exn-with-message-starts-with-predicate>)))

;;; @defsyntax test ...
;;;
;;; See above.

(define-syntax (test stx)
  (syntax-parse
   stx
   ((_ CODE:expr EXPECTED-VALS:expr RESTn ...)
    #'(test #:code CODE #:val EXPECTED-VALS RESTn ...))
   ((_ CODE:expr RESTn ...)
    #'(test #:code CODE RESTn ...))
   ((_ (~or (~optional (~seq #:id ID:expr)
                       #:name "#:id option")
            (~once     (~seq #:code CODE:expr)
                       #:name "#:code option")
            (~once     (~or (~seq #:val EXPECTED-VALS:expr)
                            #:name "#:val option"
                            (~seq #:exn EXPECTED-EXN:expr)
                            #:name "#:exn option"))
            (~optional (~seq #:val-check VALS-CHECK:expr)
                       #:name "#:val-check option")
            (~optional (~seq #:out EXPECTED-OUT:expr)
                       #:name "#:out option")
            (~optional (~seq #:out-check OUT-CHECK:expr)
                       #:name "#:out-check option")
            (~optional (~seq #:err EXPECTED-ERR:expr)
                       #:name "#:err option")
            (~optional (~seq #:err-check ERR-CHECK:expr)
                       #:name "#:err-check option")
            (~optional (~seq #:notes NOTES:expr)))
       ...)
    ;; TODO: Don't let specify "#:val-check" if "#:exn".  Is it
    ;; possible to do this with the "~or", "~seq", etc. alone?
    (with-syntax
        ((ID            (or (attribute ID)            #'#f))
         (EXPECTED-VALS (or (attribute EXPECTED-VALS) #''not-applicable))
         (EXPECTED-EXN  (or (attribute EXPECTED-EXN)  #'#f))
         (VALS-CHECK    (or (attribute VALS-CHECK)    #'equal?))
         (EXPECTED-OUT  (or (attribute EXPECTED-OUT)  #'#""))
         (EXPECTED-ERR  (or (attribute EXPECTED-ERR)  #'#""))
         (OUT-CHECK     (or (attribute OUT-CHECK)     #'equal?))
         (ERR-CHECK     (or (attribute ERR-CHECK)     #'equal?))
         (NOTES         (or (attribute NOTES)         #'#f))
         ;;
         (EXN-TEST-SETUP-VAL
          (cond ((attribute EXPECTED-VALS) #'%test-setup-values)
                ((attribute EXPECTED-EXN)  #'%test-setup-value/non-false)
                (else (error 'test
                             "internal error: expect-which setting")))))
      #`(with-handlers ((%test-setup-exn? %handle-test-setup-exn))
          (let ((id (%test-setup-values  #f "#:id" ID)))
            (%execute-test-spec
             (%make-test-spec/kw
              #:id            id
              #:code-sexp     (%test-setup-values id "#:code"      (quote CODE))
              #:code-thunk    (%test-setup-values id "#:code"      (lambda () CODE))
              #:expected-exn  (EXN-TEST-SETUP-VAL id "#:exn"       EXPECTED-EXN)
              #:expected-vals (%test-setup-values id "#:val"       (call-with-values
                                                                       (lambda ()
                                                                         EXPECTED-VALS)
                                                                     list))
              #:vals-check    (%test-setup-values id "#:val-check" VALS-CHECK)
              #:expected-out  (%test-setup-values id "#:out"       EXPECTED-OUT)
              #:expected-err  (%test-setup-values id "#:err"       EXPECTED-ERR)
              #:out-check     (%test-setup-values id "#:out-check" OUT-CHECK)
              #:err-check     (%test-setup-values id "#:err-check" ERR-CHECK)
              #:notes         (%test-setup-values id "#:notes"     NOTES)))))))))

(define (%handle-test-setup-exn exn)
  (%call-with-current-test-context-or-single
   (lambda (context)
     ((test-context-handle-test-broken context) exn)
     (void))))

;; TODO: for out and err, force expected to bytes (convert using utf-8 if
;; string), and also ensure that port encoding is utf-8.  or ucs-whatever, if
;; utf-8 doesn't make sense.

;;; @section History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 2011-08-26 -- PLaneT @code{(1 0)}
;;; Initial release.
;;;
;;; @end table

(provide
 test
 with-test-section)