overeasy.rkt
#lang racket/base

(require (for-syntax racket/base
                     syntax/parse)
         racket/port
         (planet neil/mcfly:1:0))

(doc (section "Introduction")

     (para "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."))

     (para "An individual test case, or "
           (italic "test")
           ", is specified by the programmer with the "
           (racket 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 "
            (racket current-output-port)
            " and "
            (racket current-error-port)
            "."))

     (para "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.")

     (para "A future version of Overeasy might permit the properties that are
tested to be extensible, such as for testing network state or other
resources.")

     (para "For the properties checked by tests, in most cases, the programmer
can specify both an expected value and a predicate, or "
           (italic "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 "
           (racket 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."))

(doc (subsection "Examples")

     (para "Here's a simple test, with the first argument the expression under test, and
the other argument the expected value.")

     (racketinput (test (+ 1 2 3) 6))

     (para "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 "
           (racket 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.")

     (para "Now, for a test that fails:")

     (racketinput
      (test (+ 1 2 3) 7)
      #,(racketerror "Test FAIL : Value 6 did not match expected value 7 by equal?."))

     (para "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 "
           (italic "test ID")
           " is for, and to specify it, we use the "
           (racket #:id)
           " keyword arguments in our "
           (racket test)
           ":")

     (racketinput
      (test #:id 'simple-addition
            (+ 1 2 3)
            7)
      #,(racketerror "Test FAIL simple-addition : Value 6 did not match expected value 7 by equal?."))

     (para "Quick note on syntax.  The above is actually shorthand syntax.  In the
non-shorthand syntax, every argument to "
           (racket test)
           " has a keyword, so the above is actually shorthand for:")

     (racketblock
      (test #:id   'simple-addition
            #:code (+ 1 2 3)
            #:val  7))

     (para (racket #:code)
           " and "
           (racket #:val)
           " are used so often that the keywords can be left off, so long as there are no other keyword arguments before them, other than "
           (racket #:id)
           ".")

     (para "You can even leave off the "
           (racket #:id)
           " keyword, so long as you have both "
           (italic "code")
           " and "
           (italic "val")
           " expressions, also without keywords.  So, the above example has equivalent shorthand:")

     (racketblock
      (test 'simple-addition
            (+ 1 2 3)
            7))

     (para "In the rest of these examples, we'll use the shorthand syntax, because
it's quicker to type, and getting rid of the "
           (racket #:code)
           " and "
           (racket #:val)
           " keywords also makes less-common keyword arguments stand out.")

     (para "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:")

     (racketinput
      (test (+ 1 (error "help!") 3)
            3)
      #,(racketerror "Test FAIL : Got exception #(struct:exn:fail \"help!\"), but expected value 3."))

     (para "And if an exception is the correct behavior, instead of specifying an
expected value, we can use "
           (racket #:exn)
           " to specify predicate just like for "
           (racket with-handlers)
           ":")

     (racketinput
      (test (+ 1 (error "help!") 3)
            #:exn exn:fail?))

     (para "That test passed.  But if our code under test doesn't throw an exception
matched by our "
           (racket #:exn)
           " predicate, that's a test failure:")

     (racketinput
      (test (+ 1 2 3)
            #:exn exn:fail?)
      #,(racketerror "Test FAIL : Got value 6, but expected exception matched by predicate exn:fail?."))

     (para "Of course, when you want finer discrimination of exceptions than, say,"
           (racket exn:fail?)
           " or "
           (racket exn:fail:filesystem?)
           ", you can write a custom predicate that uses "
           (racket exn-message)
           " or other information, and supply it to "
           (racket test)
           "'s "
           (racket #:exn)
           ".")

     (para "Multiple values are supported:")

     (racketinput
      (test (begin 1 2 3)
            (values 1 2 3))
      #,(racketerror "Test FAIL : Value 3 did not match expected values (1 2 3) by equal?."))

     (para "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:")

     (racketinput
      (test (string-append "a" "b" "c")
            "abc"))

     (para "But we let's say we wanted the expected and actual values to not only be "
           (racket equal?)
           " but to be "
           (racket eq?)
           " as well:")

     (racketinput
      (test (string-append "a" "b" "c")
            "abc"
            #:val-check eq?)
      #,(racketerror "Test FAIL : Value \"abc\" did not match expected value \"abc\" by eq?."))

     (para "As mentioned earlier, the checker does not have to be an equality
predicate, and it can use whatever reasoning you like in rendering its verdict
on whether the actual value should be considered OK.")

     (para "In addition to values an exceptions, "
           (racket test)
           " also intercepts and permits checking of "
           (racket current-output-port)
           " and "
           (racket 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:")

     (racketinput
      (test (let ((o (open-output-string)))
              (display 'a o) (display 'b) (display 'c o)
              (get-output-string o))
            "abc"))
     (nested #:style 'inset
             (racketerror "Test FAIL : Value \"ac\" did not match expected
value \"abc\" by equal?. Out bytes #\"b\" did not match expected #\"\" by
equal?."))

     (para "Likewise, messages to "
           (racket current-error-port)
           ", such as warnings and errors from legacy code, are also caught by
default:")

     (racketinput
      (test (begin (fprintf (current-error-port)
                            "%W%SYS$FROBINATOR_OVERHEAT\n")
                   0)
            42))
     (nested #:style 'inset
             (racketerror "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?."))

     (para "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.")

     (para "With the "
           (racket #:out-check)
           " and "
           (racket #:err-check)
           " keyword arguments to "
           (racket test)
           ", you can specify predicates other than "
           (racket equal?)
           ".  Also, by setting one of these predicates to "
           (racket #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.")

     (racketblock
      (test (begin (display "blah")
                   (display "blah")
                   (display "blah")
                   (* 44 2))
            88
            #:out-check #f))

     (para "There are some more tricks you can do with "
           (racket test)
           ".  Most notably,
you'll sometimes want to set up state in the system -- Racket parameters, test
input files, whatever.  Because the "
           (racket 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."))

(doc (subsection "Report Backends")

     (para "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."))

     (para "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."))

(doc (subsection "Test Contexts and Test Sections")

     (para "The architectural notion that permits the backends to be plugged in is
called the "
           (italic "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 "
           (italic "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.")

     (para "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.")

     (para "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 "
           (racket require)
           " or "
           (racket 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 "
           (racket fruits)
           " module, in file "
           (racket fruits.rkt)
           ", then you might want to put its unit tests in a procedure in
file "
           (racket test-fruits.rkt)
           ", like so:")

     (racketblock
      (define (test-fruits)
        (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))))

     (para "Notice that we put all the tests for module in "
           (racket fruits)
           " in "
           (racket test-section)
           " here, and gave it an ID.  The ID didn't have to be "
           (racket fruits)
           " like the module name; we could have called it "
           (racket fruity-unit-tests)
           ", "
           (racket fructose)
           ", or any other symbol.")

     (para "Then let's say we have a "
           (racket cars)
           " module, so in file "
           (racket some-cars-tests.rkt)
           ", we put this procedure:")

     (racketblock
      (define (test-drive-cars)
        (test-section
            #:id 'cars
            (test 'delorean (+ 77 11)                      88)
            (test 'ferrari  (or (and #f 'i-cant-drive) 55) 55)
            (test 'magnum   (+ 300 8)                      308))))

     (para "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 "
           (racket require)
           "s the other test modules, and invokes the each unit test procedure
within its own test section:")

     (racketblock
      (test-section
          #:id 'colossus-components
          (test-fruits)
          (test-drive-cars)))

     (para "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:")

     (verbatim
      ";; START-TESTS\n"
      ";;\n"
      ";; START-TEST-SECTION colossus-components\n"
      ";;\n"
      ";; START-TEST-SECTION fruits\n"
      ";;\n"
      ";; TEST apple\n"
      ";; (+ 1 2 3)\n"
      ";; OK\n"
      ";;\n"
      ";; TEST banana\n"
      ";; (+ 4 5 6)\n"
      ";; *FAIL* Value 15 did not match expected value 6 by equal?.\n"
      ";;\n"
      ";; TEST cherry\n"
      ";; (+ 7 8 9)\n"
      ";; OK\n"
      ";;\n"
      ";; END-TEST-SECTION fruits\n"
      ";;\n"
      ";; START-TEST-SECTION cars\n"
      ";;\n"
      ";; TEST delorean\n"
      ";; (+ 77 11)\n"
      ";; OK\n"
      ";;\n"
      ";; TEST ferrari\n"
      ";; (or (and #f (quote i-cant-drive)) 55)\n"
      ";; OK\n"
      ";;\n"
      ";; TEST magnum\n"
      ";; (+ 300 8)\n"
      ";; OK\n"
      ";;\n"
      ";; END-TEST-SECTION cars\n"
      ";;\n"
      ";; END-TEST-SECTION colossus-components\n"
      ";;\n"
      ";; END-TESTS\n"
      ";;     OK: 5  FAIL: 1  BROKEN: 0\n"
      ";;     SOME TESTS *FAILED*!\n")

     (para "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 "
           (racket test)
           " form multiple times, with different values or state each time),
or other purposes.")

     ;; TODO: Perhaps wait until an example with lots of nested sections
     ;; to say that #:id keyword is optional.

     (para "By the way, the "
           (racket #:id)
           " keyword argument itself can be left out of the "
           (racket test-section)
           " syntax, when you prefer.  So, the following two forms are
equivalent:")

     (racketblock
      (test-section #:id 'math (test (+ 1 2) 3) ...))

     (racketblock
      (test-section 'math (test (+ 1 2) 3) ...))

     )

;; TODO: Document programmatic generation of test cases and test sections, such
;; as for handling combinations.

;; TODO: Document how to test macro expansion.  Such as what we do in
;; "test-html-template.rkt", with "define-namespace-anchor" and such.

(doc (subsection "Project Status and History")

     (para "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.")

     (para "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.

     (para "As a historical note, Overeasy is much superior to the author's
2005 lightweight unit testing library, "
           (hyperlink "http://www.neilvandyke.org/testeez/" "Testeez")
           "."))

(doc (section "Interface"))

(struct exn:fail:overeasy-test exn:fail
        (result)
        #:transparent)

;; @section Test Specs

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

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

(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?
  (stx
   id
   code-sexp
   code-thunk
   expected-exn
   expected-vals
   vals-check
   expected-out
   expected-err
   out-check
   err-check
   notes)
  #:property prop:custom-write %overasy:test-spec-custom-write)

(define-syntax %overeasy:make-test-spec/kw
  (syntax-rules ()
    ((_ #:stx           stx
        #: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)
     (test-spec srcloc
                id
                code-sexp
                code-thunk
                expected-exn
                expected-vals
                vals-check
                expected-out
                expected-err
                out-check
                err-check
                notes))))

;; @section Test Results

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

(define (%overeasy: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-result spec
               actual-exn
               actual-vals
               actual-out
               actual-err
               exn-ok?
               vals-ok?
               out-ok?
               err-ok?
               ok?))

                                        ;(define %syntax->srcloc
                                        ;
                                        ;
                                        ;  (list/c any/c
                                        ;              (or/c exact-positive-integer? #f)
                                        ;              (or/c exact-nonnegative-integer? #f)
                                        ;              (or/c exact-positive-integer? #f)
                                        ;              (or/c exact-nonnegative-integer? #f))

(define (%overeasy: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."
                         (%overeasy:pretty-exn-string actual-exn)
                         (%overeasy:pretty-proc-name-string expected-exn))
                (fprintf out
                         " Got ~A, but expected exception matched by predicate ~A."
                         (%overeasy:pretty-vals (test-result-actual-vals result))
                         (%overeasy: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."
                           (%overeasy:pretty-exn-string actual-exn)
                           (%overeasy:pretty-vals expected-vals))
                  (fprintf out
                           " ~A did not match expected ~A by ~A."
                           (%overeasy:pretty-vals (test-result-actual-vals result)
                                                  #:capitalized? #t)
                           (%overeasy:pretty-vals expected-vals)
                           (%overeasy: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)
                                      (%overeasy: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

(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)
  (test-context parent
                id
                handle-start
                handle-end
                handle-child-start
                handle-child-end
                handle-test-start
                handle-test-end
                handle-test-broken))

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

(define (%overeasy:start-test-context construct-from-parent)
  (let* ((parent-context (%overeasy: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))
    (%overeasy:current-test-context new-context)))

(define (%overeasy:end-test-context)
  (let* ((old-context    (or (%overeasy:current-test-context)
                             (error '%overeasy: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))
    (%overeasy:current-test-context parent-context)))

(define-syntax %overeasy:with-test-context/construct-from-parent
  (syntax-rules ()
    ((_ CONSTRUCT-FROM-PARENT BODYn ...)
     (dynamic-wind
       (lambda ()
         (%overeasy:start-test-context CONSTRUCT-FROM-PARENT))
       (lambda ()
         BODYn ...
         (void))
       (lambda ()
         (%overeasy: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"
                  ;; TODO: Show full path of IDs to this one.  Maybe use a procedure for that.
                  (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)
                        (%overeasy:write-test-result-textual-problem-summary result os)
                        ;; TODO: Output full filename and location info on line, for Emacs compile mode.
                        (get-output-string os))))))
     #:handle-test-broken
     (lambda (exn)
       (set! broken-count (+ 1 broken-count))
       (fprintf out
                "TEST BROKEN!~A\n"
                (%overeasy:space-value-if-true
                 (%overeasy:test-setup-exn-id exn))
                (exn-message exn))))))

;; @subsection Single Test Context

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

(define (%overeasy: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 (%overeasy: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 (%overeasy: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 ((ccm  (current-continuation-marks))
                 (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)
             (%overeasy:write-test-result-textual-problem-summary result os)
             ;; (displayln (get-output-string os) out)
             (raise (exn:fail:overeasy-test (get-output-string os)
                                            ccm
                                            result)))))
     #:handle-test-broken
     (lambda (exn)
       (fprintf out
                "TEST BROKEN!~A\n"
                (%overeasy:space-value-if-true
                 (%overeasy:test-setup-exn-id exn))
                (exn-message exn))))))

;; @subsection Section Test Context

(define %overeasy: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.

(doc (defform/subs (test-section maybe-id-kw id body ...+)
       ((maybe-id-kw code:blank
                     #:id))

       "See above."))
(provide test-section)
(define-syntax (test-section stx)
  (syntax-parse stx
    ((_ ID:expr BODYn ...)
     #'(test-section #:id ID BODYn ...))
    ((_ #:id ID:expr BODYn ...)
     #'(let ((id ID))
         (%overeasy:call-with-current-test-context-or-construct
          (%overeasy:current-default-parent-test-context-for-sections)
          (lambda (parent)
            (%overeasy: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 ...)))))))

(doc (defform/subs (with-test-section maybe-id-kw id body ...+)
       ((maybe-id-kw code:blank
                     #:id))
       "Deprecated.  Alias for "
       (racket test-section)
       "."))
(provide with-test-section)
(define-syntax with-test-section
  (syntax-rules ()
    ((_ X ...)
     (test-section X ...))))

;; TODO: Is this safe?
(%overeasy: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 %overeasy:current-default-test-context-maker-for-tests (make-parameter #f))

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

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

(define-syntax %overeasy: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 (%overeasy: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 %overeasy: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 %overeasy: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 (%overeasy:test-setup-values ID WHAT-STRING EXPR)
         (raise (%overeasy: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 (%overeasy:false x)
  #f)

(define (%overeasy: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 (%overeasy:call-with-current-test-context-or-single proc)
  (cond ((%overeasy:current-test-context) => proc)
        (else (%overeasy:with-test-context/construct-from-parent
               make-single-test-context
               (proc (%overeasy:current-test-context))))))

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

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

(define (%overeasy:execute-test-spec spec)
  (%overeasy: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) (%overeasy:open-output-null)))
            (err-op    (if err-check (open-output-bytes) (%overeasy: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 %overeasy: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)
               (%overeasy: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-rx-predicate pred rx)
  (let ((<make-exn-with-message-rx-predicate>
         (lambda (e)
           (and (pred e)
                (regexp-match? rx (exn-message e))))))
    <make-exn-with-message-rx-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>)))

(begin-for-syntax
 (define-syntax-class exn-sc
   #:description "#:exn value"
   (pattern STR:str
            #:attr expanded #'(lambda (e)
                                (and (exn:fail? e)
                                     (equal? STR (exn-message e)))))
   (pattern (STR:str PRED:expr)
            #:attr expanded #'(let ((pred PRED))
                                (lambda (e)
                                  (and (pred e)
                                       (equal? STR (exn-message e))))))
   (pattern (EXPR:expr PRED:expr)
            #:attr expanded (let ((expr-e (syntax-e #'EXPR)))
                              (if (regexp? expr-e)
                                  #'(let ((pred PRED))
                                      (lambda (e)
                                        (and (exn:fail? e)
                                             (regexp-match? EXPR (exn-message e)))))
                                  #'(EXPR PRED))))
   (pattern EXPR:expr
            #:attr expanded (let ((expr-e (syntax-e #'EXPR)))
                              (if (regexp? expr-e)
                                  #'(lambda (e)
                                      (and (exn:fail? e)
                                           (regexp-match? EXPR (exn-message e))))
                                  #'EXPR)))))

;; TODO: !!! Write this documentation.
(doc (defform (test !!!)
       "See above."))
(provide test)
(define-syntax (test stx)
  (syntax-parse
      stx
    ((_ ID:expr CODE:expr VAL:expr RESTn ...)
     (syntax/loc stx
       (test #:id ID #:code CODE #:val VAL RESTn ...)))
    ((_ CODE:expr VAL:expr RESTn ...)
     (syntax/loc stx
       (test #:code CODE #:val VAL RESTn ...)))
    ((_ CODE:expr RESTn ...)
     (syntax/loc stx
       (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 VAL:expr)
                             #:name "#:val option"
                             (~seq #:exn EXN:exn-sc)
                             #:name "#:exn option"))
             (~optional (~seq #:val-check VAL-CHECK:expr)
                        #:name "#:val-check option")
             (~optional (~seq #:out OUT:expr)
                        #:name "#:out option")
             (~optional (~seq #:out-check OUT-CHECK:expr)
                        #:name "#:out-check option")
             (~optional (~seq #:err ERR:expr)
                        #:name "#:err option")
             (~optional (~seq #:err-check ERR-CHECK:expr)
                        #:name "#:err-check option")
             ;; TODO: Make "#:note" be the canonical name for "#:notes", since
             ;; it's shorter (and I accidentally said "#:note" when using it)?
             (~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))
          (VAL       (or (attribute VAL)          #''not-applicable))
          (EXN       (or (attribute EXN.expanded) #'#f))
          (VAL-CHECK (or (attribute VAL-CHECK)    #'equal?))
          (OUT       (or (attribute OUT)          #'#""))
          (ERR       (or (attribute 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 VAL) #'%overeasy:test-setup-values)
                 ((attribute EXN)  #'%overeasy:test-setup-value/non-false)
                 (else (error 'test
                              "internal error: expect-which setting")))))
       (quasisyntax/loc stx
         (with-handlers ((%overeasy:test-setup-exn? %overeasy:handle-test-setup-exn))
           (let ((id (%overeasy:test-setup-values  #f "#:id" ID)))
             (%overeasy:execute-test-spec
              (%overeasy:make-test-spec/kw
               #:stx           ,stx
               #:id            id
               #:code-sexp     (%overeasy:test-setup-values id "#:code"      (quote CODE))
               #:code-thunk    (%overeasy:test-setup-values id "#:code"      (lambda () CODE))
               #:expected-exn  (EXN-TEST-SETUP-VAL id "#:exn"       EXN)
               #:expected-vals (%overeasy:test-setup-values id "#:val"       (call-with-values
                                                                                 (lambda ()
                                                                                   VAL)
                                                                               list))
               #:vals-check    (%overeasy:test-setup-values id "#:val-check" VAL-CHECK)
               #:expected-out  (%overeasy:test-setup-values id "#:out"       OUT)
               #:expected-err  (%overeasy:test-setup-values id "#:err"       ERR)
               #:out-check     (%overeasy:test-setup-values id "#:out-check" OUT-CHECK)
               #:err-check     (%overeasy:test-setup-values id "#:err-check" ERR-CHECK)
               #:notes         (%overeasy:test-setup-values id "#:notes"     NOTES))))))))))

(define (%overeasy:handle-test-setup-exn exn)
  (%overeasy: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.

(doc history

     (#:planet 2:0 #:date "2012-06-11"

               (itemlist
                (item "Converted to McFly.")
                (item "The default test context now raises an exception with syntax location info for failed test cases, rather than only writing a message to "
                      (racket current-error-port)
                      ".")
                (item "The "
                      (racket test)
                      " syntax now preserves syntax location info better.")

                (item "Added shorthand syntax "
                      (racket (test #,(italic "ID")
                                    #,(italic "CODE")
                                    #,(italic "VAL")
                                    #,(italic "RESTn") ...))
                      ".")
                (item "The new name "
                      (racket test-section)
                      " is now preferred to the old name "
                      (racket with-test-section)
                      ".")
                (item "In "
                      (racket test-section)
                      " syntax, the "
                      (racket #:id)
                      " keyword itself is now optional.")
                (item (racket test-section)
                      " may have no "
                      (italic "body")
                      " forms.")))

     (#:version "0.1" #:planet 1:0 #:date "2011-08-26"

                "Initial release."))