src/lib/test.slate

   1
   2 "This defines a basic testing framework in the absence of proper condition-
   3 handling and other features needed for a full unit-test suite.
   4
   5 TODO
   6   - print assertion failure descriptions
   7 "
   8
   9 prototypes ensureNamespace: #testing &delegate: True.
  10 "The category for testing-related functionality."
  11
  12 testing ensureNamespace: #UnitTests.
  13 "Where the actual test data is stored."
  14
  15 testing ensureNamespace: #RegressionTests.
  16 "Where regression tests are stored."
  17
  18 testing ensureNamespace: #BenchmarkTests.
  19 "Where timed benchmark tests are stored."
  20
  21 testing@(testing) runAllTests
  22 "Run all tests in any namespace down from here. (With a strange recursion)"
  23 [| runnerBlock |
  24   runnerBlock :=
  25     [| :ns |
  26       ns slotValuesDo:
  27         [| :value |
  28           (value is: Namespace)
  29             ifTrue: [runnerBlock applyWith: value]
  30             ifFalse:
  31               [
  32                 (value is: TestCase) ifTrue:
  33                   [| result |
  34                     Console writer print: ('Running test \'' ; value printName ; '\'') paddingUntil: 40.
  35                     Console writer flush.
  36                     "Console writer ensureColumnAtLeast: 20."
  37                     "Console writer print: ('Running test \'' ; 'xxx' ; '\'') paddingUntil: 30."
  38                     Console writer ; (value runSuite printString).
  39                     Console writer newLine.
  40                   ].
  41               ].
  42         ].
  43     ].
  44   runnerBlock applyWith: UnitTests.
  45   runnerBlock applyWith: RegressionTests.
  46 ].
  47
  48 _@(testing) runAllBenchmarks
  49 [| runnerBlock |
  50   runnerBlock := [| :ns |
  51     ns slotValuesDo: [| :value |
  52       (value is: Namespace)
  53         ifTrue: [runnerBlock applyWith: value]
  54         ifFalse: [(value is: TestCase) ifTrue: [value benchmark].
  55         ].
  56       ].
  57   ].
  58   runnerBlock applyWith: BenchmarkTests.
  59 ].
  60
  61 testing define: #TestFailure &parents: {Warning}.
  62 "TestFailure traits define: #Foo &parents: {Restart}."
  63
  64 testing define: #TestCase &parents: {Cloneable} &slots:
  65  {#selector.
  66   #logErrors -> True}.
  67 "A TestCase is a Command representing the future running of a test case.
  68 Create one with the method #selector: aSymbol, passing the name of the method
  69 to be run when the test case runs.
  70 When you discover a new fixture, derive from TestCase, adding slots for the
  71 objects in the fixture, override #setUp to initialize the variables, and
  72 possibly override #tearDown to deallocate any external resources allocated
  73 in #setUp.
  74 When you are writing a test case method, send #assert: aBoolean when you want
  75 to check for an expected value. For example, you might say
  76 `case assert: socket isOpen' to test whether or not a socket is open at a
  77 point in a test."
  78
  79 t@(TestCase traits) benchmark
  80 [| pp |
  81   Console writer print: ('Running benchmark \'' ; t printName ; '\'') paddingUntil: 40.
  82   Console writer `>> [newLine. flush.].
  83   t suite tests do: [| :tc |
  84     Console writer ; '  '.
  85     Console writer print: ((tc selector) as: String) paddingUntil: 38.
  86     Console writer flush.
  87     collectGarbage.
  88     Console writer ; (([tc run] timeToRun) printString &precision: 2) ; ' seconds.'.
  89     Console writer newLine.
  90   ].
  91 ].
  92
  93 tc1@(TestCase traits) <= tc2@(TestCase traits)
  94 "Enable sorting of test cases based on their selector names."
  95 [
  96   ((tc2 selector as: String) lexicographicallyCompare: (tc1 selector as: String)) >= 0
  97 ].
  98
  99 tc@(TestCase traits) copy
 100 [
 101   resend `>> [selector := tc selector copy. ]
 102 ].
 103
 104 tc@(TestCase traits) newForSelector: selector
 105 [
 106   tc copy `>> [selector := selector. ]
 107 ].
 108
 109 tc@(TestCase traits) suiteForSelectors: selectors
 110 [| suite |
 111   suite := TestSuite new.
 112   suite tests
 113     addAll: (selectors collect: [| :sel |
 114       tc newForSelector: sel]).
 115   suite
 116 ].
 117
 118 tc@(TestCase traits) suite
 119 [
 120   overrideThis
 121 ].
 122
 123 tc@(TestCase traits) runSuite
 124 [| suite |
 125   suite := tc suite.
 126   suite run
 127 ].
 128
 129 tc@(TestCase traits) assert: _@True
 130 [tc].
 131
 132 tc@(TestCase traits) assert: _@False
 133 [
 134   tc signalFailureDescription: 'Assertion failed.'
 135 ].
 136
 137 tc@(TestCase traits) assert: bool description: descr
 138 [
 139   bool ifFalse: [tc signalFailureDescription: descr]
 140 ].
 141
 142 tc@(TestCase traits) deny: bool description: descr
 143 [
 144   tc assert: bool not description: descr
 145 ].
 146
 147 tc@(TestCase traits) deny: bool
 148 [
 149   tc assert: bool not
 150 ].
 151
 152 tc@(TestCase traits) should: block
 153 [
 154   tc assert: block do
 155 ].
 156
 157 tc@(TestCase traits) executionOf: block raises: cond
 158 "Answers whether executing the block raises the given condition."
 159 [
 160   [block on: cond do: [| :c | ^ True]]
 161     on: Condition
 162     do: [| :c | ^ False].
 163   False
 164 ].
 165
 166 tc@(TestCase traits) should: block raise: cond
 167 [
 168   tc assert: (tc executionOf: block raises: cond)
 169 ].
 170
 171 tc@(TestCase traits) should: block raise: cond description: descr
 172 [
 173   tc assert: (tc executionOf: block raises: cond) description: descr
 174 ].
 175
 176 tc@(TestCase traits) should: block description: descr
 177 [
 178   tc assert: block do description: descr
 179 ].
 180
 181 tc@(TestCase traits) shouldnt: block
 182 [
 183   tc deny: block do
 184 ].
 185
 186 tc@(TestCase traits) shouldnt: block raise: cond
 187 [
 188   tc deny: (tc executionOf: block raises: cond)
 189 ].
 190
 191 tc@(TestCase traits) shouldnt: block description: descr
 192 [
 193   tc deny: block do description: descr
 194 ].
 195
 196 tc@(TestCase traits) signalFailureDescription: descr
 197 [
 198   TestFailure signalSaying: descr
 199 ].
 200
 201 tc@(TestCase traits) defaultResources
 202 [#{}].
 203
 204 tc@(TestCase traits) resources
 205 [| result queue |
 206   result := SortedSet new.
 207   queue := ExtensibleArray new.
 208   queue addAll: tc defaultResources.
 209   [queue isEmpty] whileFalse:
 210     [| next |
 211      next := queue removeFirst.
 212      result include: next.
 213      queue addAll: next resources].
 214   result
 215 ].
 216
 217 tc@(TestCase traits) areResourcesAvailable
 218 [
 219   tc resources allSatisfy: #isAvailable `er
 220 ].
 221
 222 "TODO
 223 tc@(TestCase traits) printOn: s
 224 [
 225   tc selector printOn: s.
 226   tc ; ' findOn: {'.
 227
 228   s nextPut: $}.
 229 ].
 230 "
 231
 232 tc@(TestCase traits) setUp
 233 [tc].
 234
 235 tc@(TestCase traits) tearDown
 236 [tc].
 237
 238 tc@(TestCase traits) performTest
 239 [
 240   tc perform: tc selector
 241 ].
 242
 243 tc@(TestCase traits) runCase
 244 "TODO: separate tearDown into an ensure: clause."
 245 [
 246   [tc setUp.
 247    tc performTest]
 248      ensure: [tc tearDown]
 249 ].
 250
 251 tc@(TestCase traits) failureLog
 252 "The WriteStream to send output information to."
 253 [Console writer].
 254
 255 testing define: #TestResource &parents: {Cloneable}
 256   &slots: {#testName -> 'a Resource'.
 257            #description -> 'a Resource'}.
 258
 259 tr@(TestResource traits) defaultResources
 260 [#{}].
 261
 262 tr@(TestResource traits) resources
 263 [tr defaultResources].
 264
 265 tr@(TestResource traits) isAvailable
 266 "Whether the resource is available. Override this as necessary."
 267 [True].
 268
 269 tr@(TestResource traits) isUnavailable
 270 "Whether the resource is not available."
 271 [tr isAvailable not].
 272
 273 tr@(TestResource traits) setUp
 274 [tr].
 275
 276 tr@(TestResource traits) tearDown
 277 [tr].
 278
 279 testing define: #TestResult &parents: {Cloneable} &slots:
 280 {#failures -> Set new.
 281  #errors -> ExtensibleArray new.
 282  #passed -> ExtensibleArray new}.
 283 "A TestResult collects the tallies for a group of tests. This can be
 284 overridden and re-specialized as the second argument to run: in order to
 285 extend the reporting facilities."
 286
 287 tr@(TestResult traits) new
 288 [
 289   tr copy `>> [
 290     failures := tr failures new.
 291     errors := tr errors new.
 292     passed := tr passed new. ]
 293 ].
 294
 295 tr@(TestResult traits) failureCount
 296 [tr failures size].
 297
 298 tr@(TestResult traits) errorCount
 299 [tr errors size].
 300
 301 tr@(TestResult traits) passedCount
 302 [tr passed size].
 303
 304 tr@(TestResult traits) runCount
 305 [tr failureCount + tr passedCount + tr errorCount].
 306
 307 tr@(TestResult traits) tests
 308 [
 309   (tr errors new &capacity: tr runCount) `>> [
 310     addAll: tr passed.
 311     addAll: tr errors.
 312     addAll: tr failures. ]
 313 ].
 314
 315 tr@(TestResult traits) defects
 316 [
 317   (tr errors new &capacity: tr runCount - tr passedCount) `>> [
 318     addAll: tr errors.
 319     addAll: tr failures. ]
 320 ].
 321
 322 tr@(TestResult traits) hasFailures
 323 [
 324   tr failures isNotEmpty
 325 ].
 326
 327 tr@(TestResult traits) hasErrors
 328 [
 329   tr errors isNotEmpty
 330 ].
 331
 332 tr@(TestResult traits) hasPassed
 333 [
 334   tr hasErrors not /\ [tr hasFailures not]
 335 ].
 336
 337 tr@(TestResult traits) hasAsError: case
 338 [
 339   tr errors includes: case
 340 ].
 341
 342 tr@(TestResult traits) hasAsFailure: case
 343 [
 344   tr failures includes: case
 345 ].
 346
 347 tr@(TestResult traits) hasAsPassed: case
 348 [
 349   tr passed includes: case
 350 ].
 351
 352 tr@(TestResult traits) printOn: s
 353 [
 354   tr runCount printOn: s.
 355   s ; ' run,\t'.
 356   tr passedCount printOn: s.
 357   s ; ' passed,\t'.
 358   tr failureCount printOn: s.
 359   s ; ' failed,\t'.
 360   tr errorCount printOn: s.
 361   s ; ' error'.
 362   tr
 363 ].
 364
 365 tc@(TestCase traits) run: result
 366 "Override this for specialized result types in order to handle reporting."
 367 [| passed |
 368   passed := ([[tc runCase. True]
 369        on: TestFailure
 370        do: [| :failure |
 371             tc logErrors ifTrue: [failure describeOn: (tc failureLog)].
 372             result failures include: tc.
 373             failure exit: False]]
 374     on: Error do: [| :error |
 375                    result errors include: tc.
 376                    tc logErrors ifTrue: [error describeOn: (tc failureLog)].
 377                    error exit: False]).
 378   passed ifTrue: [result passed include: tc]
 379 ].
 380
 381 tc@(TestCase traits) run
 382 [| result |
 383   result := TestResult new.
 384   tc run: result.
 385   result
 386 ].
 387
 388 testing define: #TestSuite &parents: {Cloneable} &slots:
 389 {#tests -> SortedSet new.
 390  #resources -> Set new.
 391  #testName -> 'a TestSuite'}.
 392 "A TestSuite is a composite of TestCases and/or other TestSuites. The common
 393 entrance protocol is `suite run: result' and dependencies."
 394
 395 ts@(TestSuite traits) new
 396 "This sets up the collections as necessary. Note that calculating the resources
 397 is non-trivial but important."
 398 [ts clone `setting: #{#tests. #resources}
 399     to: {ts tests new. ts defaultResources}].
 400
 401 ts@(TestSuite traits) newNamed: name
 402 [
 403   ts new `>> [testName := name. ]
 404 ].
 405
 406 ts@(TestSuite traits) defaultResources
 407 [
 408   ts tests
 409     inject: ts resources new
 410     into: [| :set :case | set addAll: case resources. set]
 411 ].
 412
 413 ts@(TestSuite traits) isAvailable
 414 "Whether all resources are available."
 415 [
 416   ts resources allSatisfy: #isAvailable `er
 417 ].
 418
 419 ts@(TestSuite traits) run: result
 420 [
 421   ts tests
 422     do: [| :each |
 423          "ts changed: each. TODO: include with dependency-support."
 424          each run: result]
 425 ].
 426
 427 ts@(TestSuite traits) run
 428 [| result |
 429   result := TestResult new.
 430   ts resources
 431     do: [| :each | each isAvailable
 432                 ifFalse: [error: 'Resource not available: ' ; each]].
 433   [ts run: result]
 434     ensure: [ts resources do: #tearDown `er].
 435   result
 436 ].
 437
 438 ts@(TestSuite traits) printSummaryOn: s
 439 [
 440
 441 ].
 442