requires: {#Set. #ExtensibleArray. #Condition. #Error}.
provides: {#TestCase. #TestResult. #TestResource. #TestSuite}.

"This defines a basic testing framework in the absence of proper condition-
handling and other features needed for a full unit-test suite."

prototypes ensureDelegatedNamespace: #testing.
"The category for testing-related functionality."
testing ensureNamespace: #Tests.
"Where the actual test data is stored."

testing addPrototype: #TestFailure derivedFrom: {Warning}.
TestFailure traits addPrototype: #Foo derivedFrom: {Restart}.

testing addPrototype: #TestCase derivedFrom: {Cloneable}.
"A TestCase is a Command representing the future running of a test case.
Create one with the method #selector: aSymbol, passing the name of the method
to be run when the test case runs.
When you discover a new fixture, derive from TestCase, adding slots for the
objects in the fixture, override #setUp to initialize the variables, and
possibly override #tearDown to deallocate any external resources allocated
in #setUp.
When you are writing a test case method, send #assert: aBoolean when you want
to check for an expected value. For example, you might say
`case assert: socket isOpen' to test whether or not a socket is open at a
point in a test."
TestCase addSlot: #selector.

tc@(TestCase traits) copy
[|newCase|
  newCase: resend.
  newCase selector: tc selector copy.
  newCase
].

tc@(TestCase traits) newForSelector: selector
[| newCase |
  newCase: tc copy.
  newCase selector: selector.
  newCase
].

tc@(TestCase traits) assert: _@True
[tc].

tc@(TestCase traits) assert: _@False
[
  tc signalFailureDescription: 'Assertion failed.'
].

tc@(TestCase traits) assert: bool description: descr
[
  bool
    ifFalse: [tc logFailure: descr.
	      (TestFailure newDescription: descr) signal]
].

tc@(TestCase traits) deny: bool description: descr
[
  tc assert: bool not description: descr
].

tc@(TestCase traits) deny: bool
[
  tc assert: bool not
].

tc@(TestCase traits) should: block
[
  tc assert: block do
].

tc@(TestCase traits) executeShould: block inScopeOf: cond
"Answers whether executing the block raises the given condition."
[
  block on: cond do: [| :c | ^ True].

  False
].
tc@(TestCase traits) should: block raise: cond
[
  tc assert: (tc executeShould: block inScopeOf: cond)
].

tc@(TestCase traits) should: block raise: cond description: descr
[
  tc assert: (tc executeShould: block inScopeOf: cond) description: descr
].

tc@(TestCase traits) should: block description: descr
[
  tc assert: block do description: descr
].

tc@(TestCase traits) shouldnt: block
[
  tc deny: block do
].

tc@(TestCase traits) shouldnt: block raise: cond
[
  tc deny: (tc executeShould: block inScopeOf: cond)
].

tc@(TestCase traits) shouldnt: block description: descr
[
  tc deny: block do description: descr
].

tc@(TestCase traits) signalFailureDescription: descr
[
  (TestFailure newDescription: descr) signal
].

tc@(TestCase traits) defaultResources
[{}].

tc@(TestCase traits) resources
[| result queue |
  result: Set newEmpty.
  queue: ExtensibleArray newEmpty.
  queue addAll: tc defaultResources.
  [queue isEmpty] whileFalse:
    [| next |
     next: queue removeFirst.
     result include: next.
     queue addAll: next resources].
  result
].

tc@(TestCase traits) areResourcesAvailable
[
  tc resources inject: True into:
    [| :total :each | each isAvailable /\ total]
].

"
tc@(TestCase traits) printOn: s
[
  tc selector printOn: s.
  tc ; ' findOn: {'.
  
  s nextPut: $}.
].
"

tc@(TestCase traits) setUp
[tc].

tc@(TestCase traits) tearDown
[tc].

tc@(TestCase traits) performTest
[
  tc perform: tc selector
].

tc@(TestCase traits) runCase
"TODO: separate tearDown into an ensure: clause."
[
  [tc setUp.
   tc performTest]
     ensure: [tc tearDown]
].

tc@(TestCase traits) failureLog
"The WriteStream to send output information to."
[Console writer].

tc@(TestCase traits) isLogging
"Whether failures should be logged."
[False].

tc@(TestCase traits) logFailure: descr
[
  tc isLogging
     ifTrue: [tc failureLog ; '\n' ; descr.
	      tc failureLog flush].
  tc
].

testing addPrototype: #TestResource derivedFrom: {Cloneable}.
TestResource addSlot: #testName valued: 'a Resource'.
TestResource addSlot: #description valued: 'a Resource'.

tr@(TestResource traits) defaultResources
[{}].

tr@(TestResource traits) resources
[tr defaultResources].

tr@(TestResource traits) isAvailable
"Whether the resource is available. Override this as necessary."
[True].

tr@(TestResource traits) isUnavailable
"Whether the resource is not available."
[tr isAvailable not].

tr@(TestResource traits) setUp
[tr].

tr@(TestResource traits) tearDown
[tr].

testing addPrototype: #TestResult derivedFrom: {Cloneable}.
"A TestResult collects the tallies for a group of tests. This can be
overridden and re-specialized as the second argument to run: in order to
extend the reporting facilities."
TestResult addSlot: #failures valued: Set newEmpty.
TestResult addSlot: #errors valued: ExtensibleArray newEmpty.
TestResult addSlot: #passed valued: ExtensibleArray newEmpty.

tr@(TestResult traits) newEmpty
[| newTR |
  newTR: tr copy.
  newTR failures: tr failures newEmpty.
  newTR errors: tr errors newEmpty.
  newTR passed: tr passed newEmpty.
  newTR
].

tr@(TestResult traits) failureCount
[tr failures size].

tr@(TestResult traits) errorCount
[tr errors size].

tr@(TestResult traits) passedCount
[tr passed size].

tr@(TestResult traits) runCount
[tr failureCount + tr passedCount + tr errorCount].

tr@(TestResult traits) tests
[| result |
  result: (tr errors newSize: tr runCount).
  result addAll: tr passed.
  result addAll: tr errors.
  result addAll: tr failures.
  result
].

tr@(TestResult traits) defects
[| result |
  result: (tr errors newSize: tr runCount - tr passedCount).
  result addAll: tr errors.
  result addAll: tr failures.
  result
].

tr@(TestResult traits) hasFailures
[
  tr failures isNotEmpty
].

tr@(TestResult traits) hasErrors
[
  tr errors isNotEmpty
].

tr@(TestResult traits) hasPassed
[
  tr hasErrors not and: [tr hasFailures not]
].

tr@(TestResult traits) hasAsError: case
[
  tr errors includes: case
].

tr@(TestResult traits) hasAsFailure: case
[
  tr failures includes: case
].

tr@(TestResult traits) hasAsPassed: case
[
  tr passed includes: case
].

tr@(TestResult traits) printOn: s
[
  tr runCount printOn: s.
  s ; ' run, '.
  tr passedCount printOn: s.
  s ; ' passed, '.
  tr failureCount printOn: s.
  s ; ' failed, '.
  tr errorCount printOn: s.
  s ; ' error'.
  tr errorCount > 1 ifTrue: [s nextPut: $s].
  tr
].

tc@(TestCase traits) run: result
"Override this for specialized result types in order to handle reporting."
[| passed |
  passed: ([[tc runCase. True]
     on: TestFailure
     do: [| :failure |
	  result failures include: tc.
	  failure exit: False]]
    on: Error do: [| :error |
		   result errors include: tc.
		   error exit: False]).
  passed ifTrue: [result passed include: tc]
].

tc@(TestCase traits) run
[| result |
  result: TestResult newEmpty.
  tc run: result.
  result
].

testing addPrototype: #TestSuite derivedFrom: {Cloneable}.
"A TestSuite is a composite of TestCases and/or other TestSuites. The common
entrance protocol is `suite run: result' and dependencies."
TestSuite addSlot: #tests valued: Set newEmpty.
TestSuite addSlot: #resources valued: Set newEmpty.
TestSuite addSlot: #testName valued: 'a TestSuite'.

ts@(TestSuite traits) newEmpty
"This sets up the collections as necessary. Note that calculating the resources
is non-trivial but important."
[| newTS |
  newTS: ts clone.
  newTS tests: newTS tests newEmpty.
  newTS resources: newTS defaultResources.
  newTS
].

ts@(TestSuite traits) newNamed: name
[| newTS |
  newTS: ts newEmpty.
  newTS testName: name.
  newTS
].

ts@(TestSuite traits) defaultResources
[
  ts tests
    inject: ts resources newEmpty
    into: [| :set :case | set addAll: case resources. set]
].

ts@(TestSuite traits) isAvailable
"Whether all resources are available."
[
  ts resources
    inject: True
    into: [| :result :each | each isAvailable /\ result]
].

ts@(TestSuite traits) run: result
[
  ts tests
    do: [| :each |
	 "ts changed: each. TODO: include with dependency-support."
	 each run: result]
].

ts@(TestSuite traits) run
[| result |
  result: TestResult newEmpty.
  ts resources
    do: [| :each | each isAvailable
		ifFalse: [error: 'Resource not available: ' ; each]].
  [ts run: result]
    ensure: [ts resources do: [| :each | each tearDown]].
  result
].

ts@(TestSuite traits) printSummaryOn: s
[
  
].

Tests addSlot: #CurrentUnit.
"The slot for activating the most-recently loaded test suite."