requires: {#Set. #ExtensibleSequence. #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 addDelegate: #testing valued: Namespace clone.
"The category for testing-related functionality."
tests addSlot: #Tests valued: Namespace clone.
"Where the actual test data is stored."

testing addSlot: #TestCase valued: Cloneable derive.
"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) newForSelector: selector
[| newCase |
  newCase: tc clone.
  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.
	      TestResult newFailure signalWith: descr]
].

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 value
].

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

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

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

tc@(TestCase traits) signalFailureDescription: descr
[
  TestResult newFailure signalWith: descr
].

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

tc@(TestCase traits) resources
[| result queue |
  result: Set newEmpty.
  queue: ExtensibleSequence 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
[
  s ; tc name ; '>>#' ; tc selector
].

tc@(TestCase traits) setUp
[tc].

tc@(TestCase traits) tearDown
[tc].

tc@(TestCase traits) performTest
[
  tc perform: 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."
[ConsoleOutput].

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 addSlot: #TestResource valued: Cloneable derive.
TestResource addSlot: #testName valued: ''.
TestResource addSlot: #description valued: ''.

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

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

tr@(TestResource traits) name
[
  tr testName ifNil: [resend]
].

tr@(TestResource traits) name: str
[
  tr testName: str
].

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 addSlot: #TestResult valued: Cloneable derive.
"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: ExtensibleSequence newEmpty.
TestResult addSlot: #passed valued: ExtensibleSequence newEmpty.

tr@(TestResult traits) newEmpty
[| newTR |
  newTR: tr clone.
  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 size > 0
].

tr@(TestResult traits) hasErrors
[
  tr errors size > 0
].

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.
  tr ; ' run, '.
  tr passedCount printOn: s.
  tr ; ' passed, '.
  tr failureCount printOn: s.
  tr ; ' failed, '.
  tr errorCount printOn: s.
  tr ; ' 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."
"TODO: add the SUnit exception-handling support."
[| passed |
  passed: [tc runCase. True] value.
  passed ifTrue: [result passed include: tc]
].

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

testing addSlot: #TestSuite valued: Cloneable derive.
"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: ''.

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 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 myResources 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 clone.
  ts resources
    do: [| :each | each isAvailable
		ifFalse: [^ (error: 'Resource not available: ' ; each)]].
  
  [ts run: result]
    ensure: [tc resources do: [| :each | each tearDown]].
  result
].

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

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