;; SUnit — minimal port written in SX-Smalltalk, run by smalltalk-load.
;;
;; Provides:
;;   TestCase     — base class. Subclass it, add `testSomething` methods.
;;   TestSuite    — a collection of TestCase instances; runs them all.
;;   TestResult   — passes / failures / errors counts and lists.
;;   TestFailure  — Error subclass raised by `assert:` and friends.
;;
;; Conventions:
;;   - Test methods are run in a fresh instance per test.
;;   - `setUp` is sent before each test; `tearDown` after.
;;   - Failures are signalled by TestFailure; runner catches and records.

(define
  st-sunit-source
  "Error subclass: #TestFailure
     instanceVariableNames: ''!

   Object subclass: #TestCase
     instanceVariableNames: 'testSelector'!

   !TestCase methodsFor: 'access'!
   testSelector ^ testSelector!
   testSelector: aSym testSelector := aSym. ^ self! !

   !TestCase methodsFor: 'fixture'!
   setUp ^ self!
   tearDown ^ self! !

   !TestCase methodsFor: 'asserts'!
   assert: aBoolean
     aBoolean ifFalse: [TestFailure signal: 'assertion failed'].
     ^ self!

   assert: aBoolean description: aString
     aBoolean ifFalse: [TestFailure signal: aString].
     ^ self!

   assert: actual equals: expected
     actual = expected ifFalse: [
       TestFailure signal: 'expected ' , expected printString
                           , ' but got ' , actual printString].
     ^ self!

   deny: aBoolean
     aBoolean ifTrue: [TestFailure signal: 'denial failed'].
     ^ self!

   should: aBlock raise: anExceptionClass
     | raised |
     raised := false.
     [aBlock value] on: anExceptionClass do: [:e | raised := true].
     raised ifFalse: [
       TestFailure signal: 'expected exception ' , anExceptionClass name
                           , ' was not raised'].
     ^ self!

   shouldnt: aBlock raise: anExceptionClass
     | raised |
     raised := false.
     [aBlock value] on: anExceptionClass do: [:e | raised := true].
     raised ifTrue: [
       TestFailure signal: 'unexpected exception ' , anExceptionClass name].
     ^ self! !

   !TestCase methodsFor: 'running'!
   runCase
     self setUp.
     self perform: testSelector.
     self tearDown.
     ^ self! !

   !TestCase class methodsFor: 'instantiation'!
   selector: aSym ^ self new testSelector: aSym!

   suiteForAll: aSelectorArray
     | suite |
     suite := TestSuite new init.
     suite name: self name.
     aSelectorArray do: [:s | suite addTest: (self selector: s)].
     ^ suite! !

   Object subclass: #TestResult
     instanceVariableNames: 'passes failures errors'!

   !TestResult methodsFor: 'init'!
   init
     passes := Array new: 0.
     failures := Array new: 0.
     errors := Array new: 0.
     ^ self! !

   !TestResult methodsFor: 'access'!
   passes ^ passes!
   failures ^ failures!
   errors ^ errors!
   passCount ^ passes size!
   failureCount ^ failures size!
   errorCount ^ errors size!
   totalCount ^ passes size + failures size + errors size!

   addPass: aTest passes add: aTest. ^ self!
   addFailure: aTest message: aMsg
     | rec |
     rec := Array new: 2.
     rec at: 1 put: aTest. rec at: 2 put: aMsg.
     failures add: rec.
     ^ self!
   addError: aTest message: aMsg
     | rec |
     rec := Array new: 2.
     rec at: 1 put: aTest. rec at: 2 put: aMsg.
     errors add: rec.
     ^ self!

   isEmpty ^ self totalCount = 0!
   allPassed ^ (failures size + errors size) = 0!

   summary
     ^ 'Tests: {1}  Passed: {2}  Failed: {3}  Errors: {4}'
         format: (Array
                    with: self totalCount printString
                    with: passes size printString
                    with: failures size printString
                    with: errors size printString)! !

   Object subclass: #TestSuite
     instanceVariableNames: 'tests name'!

   !TestSuite methodsFor: 'init'!
   init tests := Array new: 0. name := 'Suite'. ^ self!
   name ^ name!
   name: aString name := aString. ^ self! !

   !TestSuite methodsFor: 'tests'!
   tests ^ tests!
   addTest: aTest tests add: aTest. ^ self!
   addAll: aCollection aCollection do: [:t | self addTest: t]. ^ self!
   size ^ tests size! !

   !TestSuite methodsFor: 'running'!
   run
     | result |
     result := TestResult new init.
     tests do: [:t | self runTest: t result: result].
     ^ result!

   runTest: aTest result: aResult
     [aTest runCase. aResult addPass: aTest]
       on: TestFailure do: [:e | aResult addFailure: aTest message: e messageText].
     ^ self! !")

(smalltalk-load st-sunit-source)