srfi-64-test.scm 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941
  1. ;;;
  2. ;;; This is a test suite written in the notation of
  3. ;;; SRFI-64, A Scheme API for test suites
  4. ;;;
  5. (test-begin "SRFI 64 - Meta-Test Suite")
  6. ;;;
  7. ;;; Ironically, in order to set up the meta-test environment,
  8. ;;; we have to invoke one of the most sophisticated features:
  9. ;;; custom test runners
  10. ;;;
  11. ;;; The `prop-runner' invokes `thunk' in the context of a new
  12. ;;; test runner, and returns the indicated properties of the
  13. ;;; last-executed test result.
  14. (define (prop-runner props thunk)
  15. (let ((r (test-runner-null))
  16. (plist '()))
  17. ;;
  18. (test-runner-on-test-end!
  19. r
  20. (lambda (runner)
  21. (set! plist (test-result-alist runner))))
  22. ;;
  23. (test-with-runner r (thunk))
  24. ;; reorder the properties so they are in the order
  25. ;; given by `props'. Note that any property listed in `props'
  26. ;; that is not in the property alist will occur as #f
  27. (map (lambda (k)
  28. (assq k plist))
  29. props)))
  30. ;;; `on-test-runner' creates a null test runner and then
  31. ;;; arranged for `visit' to be called with the runner
  32. ;;; whenever a test is run. The results of the calls to
  33. ;;; `visit' are returned in a list
  34. (define (on-test-runner thunk visit)
  35. (let ((r (test-runner-null))
  36. (results '()))
  37. ;;
  38. (test-runner-on-test-end!
  39. r
  40. (lambda (runner)
  41. (set! results (cons (visit r) results))))
  42. ;;
  43. (test-with-runner r (thunk))
  44. (reverse results)))
  45. ;;;
  46. ;;; The `triv-runner' invokes `thunk'
  47. ;;; and returns a list of 6 lists, the first 5 of which
  48. ;;; are a list of the names of the tests that, respectively,
  49. ;;; PASS, FAIL, XFAIL, XPASS, and SKIP.
  50. ;;; The last item is a list of counts.
  51. ;;;
  52. (define (triv-runner thunk)
  53. (let ((r (test-runner-null))
  54. (accum-pass '())
  55. (accum-fail '())
  56. (accum-xfail '())
  57. (accum-xpass '())
  58. (accum-skip '()))
  59. ;;
  60. (test-runner-on-bad-count!
  61. r
  62. (lambda (runner count expected-count)
  63. (error (string-append "bad count " (number->string count)
  64. " but expected "
  65. (number->string expected-count)))))
  66. (test-runner-on-bad-end-name!
  67. r
  68. (lambda (runner begin end)
  69. (error (string-append "bad end group name " end
  70. " but expected " begin))))
  71. (test-runner-on-test-end!
  72. r
  73. (lambda (runner)
  74. (let ((n (test-runner-test-name runner)))
  75. (case (test-result-kind runner)
  76. ((pass) (set! accum-pass (cons n accum-pass)))
  77. ((fail) (set! accum-fail (cons n accum-fail)))
  78. ((xpass) (set! accum-xpass (cons n accum-xpass)))
  79. ((xfail) (set! accum-xfail (cons n accum-xfail)))
  80. ((skip) (set! accum-skip (cons n accum-skip)))))))
  81. ;;
  82. (test-with-runner r (thunk))
  83. (list (reverse accum-pass) ; passed as expected
  84. (reverse accum-fail) ; failed, but was expected to pass
  85. (reverse accum-xfail) ; failed as expected
  86. (reverse accum-xpass) ; passed, but was expected to fail
  87. (reverse accum-skip) ; was not executed
  88. (list (test-runner-pass-count r)
  89. (test-runner-fail-count r)
  90. (test-runner-xfail-count r)
  91. (test-runner-xpass-count r)
  92. (test-runner-skip-count r)))))
  93. (define (path-revealing-runner thunk)
  94. (let ((r (test-runner-null))
  95. (seq '()))
  96. ;;
  97. (test-runner-on-test-end!
  98. r
  99. (lambda (runner)
  100. (set! seq (cons (list (test-runner-group-path runner)
  101. (test-runner-test-name runner))
  102. seq))))
  103. (test-with-runner r (thunk))
  104. (reverse seq)))
  105. ;;;
  106. ;;; Now we can start testing compliance with SRFI-64
  107. ;;;
  108. (test-begin "1. Simple test-cases")
  109. (test-begin "1.1. test-assert")
  110. (define (t)
  111. (triv-runner
  112. (lambda ()
  113. (test-assert "a" #t)
  114. (test-assert "b" #f))))
  115. (test-equal
  116. "1.1.1. Very simple"
  117. '(("a") ("b") () () () (1 1 0 0 0))
  118. (t))
  119. (test-equal
  120. "1.1.2. A test with no name"
  121. '(("a") ("") () () () (1 1 0 0 0))
  122. (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
  123. (test-equal
  124. "1.1.3. Tests can have the same name"
  125. '(("a" "a") () () () () (2 0 0 0 0))
  126. (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
  127. (define (choke)
  128. (vector-ref '#(1 2) 3))
  129. (test-equal
  130. "1.1.4. One way to FAIL is to throw an error"
  131. '(() ("a") () () () (0 1 0 0 0))
  132. (triv-runner (lambda () (test-assert "a" (choke)))))
  133. (test-end);1.1
  134. (test-begin "1.2. test-eqv")
  135. (define (mean x y)
  136. (/ (+ x y) 2.0))
  137. (test-equal
  138. "1.2.1. Simple numerical equivalence"
  139. '(("c") ("a" "b") () () () (1 2 0 0 0))
  140. (triv-runner
  141. (lambda ()
  142. (test-eqv "a" (mean 3 5) 4)
  143. (test-eqv "b" (mean 3 5) 4.5)
  144. (test-eqv "c" (mean 3 5) 4.0))))
  145. (test-end);1.2
  146. (test-end "1. Simple test-cases")
  147. ;;;
  148. ;;;
  149. ;;;
  150. (test-begin "2. Tests for catching errors")
  151. (test-begin "2.1. test-error")
  152. (test-equal
  153. "2.1.1. Baseline test; PASS with no optional args"
  154. '(("") () () () () (1 0 0 0 0))
  155. (triv-runner
  156. (lambda ()
  157. ;; PASS
  158. (test-error (vector-ref '#(1 2) 9)))))
  159. (test-equal
  160. "2.1.2. Baseline test; FAIL with no optional args"
  161. '(() ("") () () () (0 1 0 0 0))
  162. (triv-runner
  163. (lambda ()
  164. ;; FAIL: the expr does not raise an error and `test-error' is
  165. ;; claiming that it will, so this test should FAIL
  166. (test-error (vector-ref '#(1 2) 0)))))
  167. (test-equal
  168. "2.1.3. PASS with a test name and error type"
  169. '(("a") () () () () (1 0 0 0 0))
  170. (triv-runner
  171. (lambda ()
  172. ;; PASS
  173. (test-error "a" #t (vector-ref '#(1 2) 9)))))
  174. (test-end "2.1. test-error")
  175. (test-end "2. Tests for catching errors")
  176. ;;;
  177. ;;;
  178. ;;;
  179. (test-begin "3. Test groups and paths")
  180. (test-equal
  181. "3.1. test-begin with unspecific test-end"
  182. '(("b") () () () () (1 0 0 0 0))
  183. (triv-runner
  184. (lambda ()
  185. (test-begin "a")
  186. (test-assert "b" #t)
  187. (test-end))))
  188. (test-equal
  189. "3.2. test-begin with name-matching test-end"
  190. '(("b") () () () () (1 0 0 0 0))
  191. (triv-runner
  192. (lambda ()
  193. (test-begin "a")
  194. (test-assert "b" #t)
  195. (test-end "a"))))
  196. ;;; since the error raised by `test-end' on a mismatch is not a test
  197. ;;; error, we actually expect the triv-runner itself to fail
  198. (test-error
  199. "3.3. test-begin with mismatched test-end"
  200. #t
  201. (triv-runner
  202. (lambda ()
  203. (test-begin "a")
  204. (test-assert "b" #t)
  205. (test-end "x"))))
  206. (test-equal
  207. "3.4. test-begin with name and count"
  208. '(("b" "c") () () () () (2 0 0 0 0))
  209. (triv-runner
  210. (lambda ()
  211. (test-begin "a" 2)
  212. (test-assert "b" #t)
  213. (test-assert "c" #t)
  214. (test-end "a"))))
  215. ;; similarly here, a mismatched count is a lexical error
  216. ;; and not a test failure...
  217. (test-error
  218. "3.5. test-begin with mismatched count"
  219. #t
  220. (triv-runner
  221. (lambda ()
  222. (test-begin "a" 99)
  223. (test-assert "b" #t)
  224. (test-end "a"))))
  225. (test-equal
  226. "3.6. introspecting on the group path"
  227. '((() "w")
  228. (("a" "b") "x")
  229. (("a" "b") "y")
  230. (("a") "z"))
  231. ;;
  232. ;; `path-revealing-runner' is designed to return a list
  233. ;; of the tests executed, in order. Each entry is a list
  234. ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
  235. ;; of test groups starting from the topmost
  236. ;;
  237. (path-revealing-runner
  238. (lambda ()
  239. (test-assert "w" #t)
  240. (test-begin "a")
  241. (test-begin "b")
  242. (test-assert "x" #t)
  243. (test-assert "y" #t)
  244. (test-end)
  245. (test-assert "z" #t))))
  246. (test-end "3. Test groups and paths")
  247. ;;;
  248. ;;;
  249. ;;;
  250. (test-begin "4. Handling set-up and cleanup")
  251. (test-equal "4.1. Normal exit path"
  252. '(in 1 2 out)
  253. (let ((ex '()))
  254. (define (do s)
  255. (set! ex (cons s ex)))
  256. ;;
  257. (triv-runner
  258. (lambda ()
  259. (test-group-with-cleanup
  260. "foo"
  261. (do 'in)
  262. (do 1)
  263. (do 2)
  264. (do 'out))))
  265. (reverse ex)))
  266. (test-equal "4.2. Exception exit path"
  267. '(in 1 out)
  268. (let ((ex '()))
  269. (define (do s)
  270. (set! ex (cons s ex)))
  271. ;;
  272. ;; the outer runner is to run the `test-error' in, to
  273. ;; catch the exception raised in the inner runner,
  274. ;; since we don't want to depend on any other
  275. ;; exception-catching support
  276. ;;
  277. (triv-runner
  278. (lambda ()
  279. (test-error
  280. (triv-runner
  281. (lambda ()
  282. (test-group-with-cleanup
  283. "foo"
  284. (do 'in) (test-assert #t)
  285. (do 1) (test-assert #t)
  286. (choke) (test-assert #t)
  287. (do 2) (test-assert #t)
  288. (do 'out)))))))
  289. (reverse ex)))
  290. (test-end "4. Handling set-up and cleanup")
  291. ;;;
  292. ;;;
  293. ;;;
  294. (test-begin "5. Test specifiers")
  295. (test-begin "5.1. test-match-named")
  296. (test-equal "5.1.1. match test names"
  297. '(("y") () () () ("x") (1 0 0 0 1))
  298. (triv-runner
  299. (lambda ()
  300. (test-skip (test-match-name "x"))
  301. (test-assert "x" #t)
  302. (test-assert "y" #t))))
  303. (test-equal "5.1.2. but not group names"
  304. '(("z") () () () () (1 0 0 0 0))
  305. (triv-runner
  306. (lambda ()
  307. (test-skip (test-match-name "x"))
  308. (test-begin "x")
  309. (test-assert "z" #t)
  310. (test-end))))
  311. (test-end)
  312. (test-begin "5.2. test-match-nth")
  313. ;; See also: [6.4. Short-circuit evaluation]
  314. (test-equal "5.2.1. skip the nth one after"
  315. '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
  316. (triv-runner
  317. (lambda ()
  318. (test-assert "v" #t)
  319. (test-skip (test-match-nth 2))
  320. (test-assert "w" #t) ; 1
  321. (test-assert "x" #t) ; 2 SKIP
  322. (test-assert "y" #t) ; 3
  323. (test-assert "z" #t)))) ; 4
  324. (test-equal "5.2.2. skip m, starting at n"
  325. '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
  326. (triv-runner
  327. (lambda ()
  328. (test-assert "v" #t)
  329. (test-skip (test-match-nth 2 2))
  330. (test-assert "w" #t) ; 1
  331. (test-assert "x" #t) ; 2 SKIP
  332. (test-assert "y" #t) ; 3 SKIP
  333. (test-assert "z" #t)))) ; 4
  334. (test-end)
  335. (test-begin "5.3. test-match-any")
  336. (test-equal "5.3.1. basic disjunction"
  337. '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
  338. (triv-runner
  339. (lambda ()
  340. (test-assert "v" #t)
  341. (test-skip (test-match-any (test-match-nth 3)
  342. (test-match-name "x")))
  343. (test-assert "w" #t) ; 1
  344. (test-assert "x" #t) ; 2 SKIP(NAME)
  345. (test-assert "y" #t) ; 3 SKIP(COUNT)
  346. (test-assert "z" #t)))) ; 4
  347. (test-equal "5.3.2. disjunction is commutative"
  348. '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
  349. (triv-runner
  350. (lambda ()
  351. (test-assert "v" #t)
  352. (test-skip (test-match-any (test-match-name "x")
  353. (test-match-nth 3)))
  354. (test-assert "w" #t) ; 1
  355. (test-assert "x" #t) ; 2 SKIP(NAME)
  356. (test-assert "y" #t) ; 3 SKIP(COUNT)
  357. (test-assert "z" #t)))) ; 4
  358. (test-end)
  359. (test-begin "5.4. test-match-all")
  360. (test-equal "5.4.1. basic conjunction"
  361. '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
  362. (triv-runner
  363. (lambda ()
  364. (test-assert "v" #t)
  365. (test-skip (test-match-all (test-match-nth 2 2)
  366. (test-match-name "x")))
  367. (test-assert "w" #t) ; 1
  368. (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
  369. (test-assert "y" #t) ; 3 SKIP(COUNT)
  370. (test-assert "z" #t)))) ; 4
  371. (test-equal "5.4.2. conjunction is commutative"
  372. '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
  373. (triv-runner
  374. (lambda ()
  375. (test-assert "v" #t)
  376. (test-skip (test-match-all (test-match-name "x")
  377. (test-match-nth 2 2)))
  378. (test-assert "w" #t) ; 1
  379. (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
  380. (test-assert "y" #t) ; 3 SKIP(COUNT)
  381. (test-assert "z" #t)))) ; 4
  382. (test-end)
  383. (test-end "5. Test specifiers")
  384. ;;;
  385. ;;;
  386. ;;;
  387. (test-begin "6. Skipping selected tests")
  388. (test-equal
  389. "6.1. Skip by specifier - match-name"
  390. '(("x") () () () ("y") (1 0 0 0 1))
  391. (triv-runner
  392. (lambda ()
  393. (test-begin "a")
  394. (test-skip (test-match-name "y"))
  395. (test-assert "x" #t) ; PASS
  396. (test-assert "y" #f) ; SKIP
  397. (test-end))))
  398. (test-equal
  399. "6.2. Shorthand specifiers"
  400. '(("x") () () () ("y") (1 0 0 0 1))
  401. (triv-runner
  402. (lambda ()
  403. (test-begin "a")
  404. (test-skip "y")
  405. (test-assert "x" #t) ; PASS
  406. (test-assert "y" #f) ; SKIP
  407. (test-end))))
  408. (test-begin "6.3. Specifier Stack")
  409. (test-equal
  410. "6.3.1. Clearing the Specifier Stack"
  411. '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
  412. (triv-runner
  413. (lambda ()
  414. (test-begin "a then b")
  415. (test-begin "a")
  416. (test-skip "y")
  417. (test-assert "x" #t) ; PASS
  418. (test-assert "y" #f) ; SKIP
  419. (test-end)
  420. (test-begin "b")
  421. (test-assert "x" #t) ; PASS
  422. (test-assert "y" #f) ; FAIL
  423. (test-end)
  424. (test-end))))
  425. (test-equal
  426. "6.3.2. Inheriting the Specifier Stack"
  427. '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
  428. (triv-runner
  429. (lambda ()
  430. (test-begin "a then b")
  431. (test-skip "y")
  432. (test-begin "a")
  433. (test-assert "x" #t) ; PASS
  434. (test-assert "y" #f) ; SKIP
  435. (test-end)
  436. (test-begin "b")
  437. (test-assert "x" #t) ; PASS
  438. (test-assert "y" #f) ; SKIP
  439. (test-end)
  440. (test-end))))
  441. (test-end);6.3
  442. (test-begin "6.4. Short-circuit evaluation")
  443. (test-equal
  444. "6.4.1. In test-match-all"
  445. '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
  446. (triv-runner
  447. (lambda ()
  448. (test-begin "a")
  449. (test-skip (test-match-all "y" (test-match-nth 2)))
  450. ;; let's label the substructure forms so we can
  451. ;; see which one `test-match-nth' is going to skip
  452. ;; ; # "y" 2 result
  453. (test-assert "x" #t) ; 1 - #f #f PASS
  454. (test-assert "y" #f) ; 2 - #t #t SKIP
  455. (test-assert "y" #f) ; 3 - #t #f FAIL
  456. (test-assert "x" #f) ; 4 - #f #f FAIL
  457. (test-assert "z" #f) ; 5 - #f #f FAIL
  458. (test-end))))
  459. (test-equal
  460. "6.4.2. In separate skip-list entries"
  461. '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
  462. (triv-runner
  463. (lambda ()
  464. (test-begin "a")
  465. (test-skip "y")
  466. (test-skip (test-match-nth 2))
  467. ;; let's label the substructure forms so we can
  468. ;; see which one `test-match-nth' is going to skip
  469. ;; ; # "y" 2 result
  470. (test-assert "x" #t) ; 1 - #f #f PASS
  471. (test-assert "y" #f) ; 2 - #t #t SKIP
  472. (test-assert "y" #f) ; 3 - #t #f SKIP
  473. (test-assert "x" #f) ; 4 - #f #f FAIL
  474. (test-assert "z" #f) ; 5 - #f #f FAIL
  475. (test-end))))
  476. (test-begin "6.4.3. Skipping test suites")
  477. (test-equal
  478. "6.4.3.1. Introduced using 'test-begin'"
  479. '(("x") () () () () (1 0 0 0 0))
  480. (triv-runner
  481. (lambda ()
  482. (test-begin "a")
  483. (test-skip "b")
  484. (test-begin "b") ; not skipped
  485. (test-assert "x" #t)
  486. (test-end "b")
  487. (test-end "a"))))
  488. (test-expect-fail 1) ;; ???
  489. (test-equal
  490. "6.4.3.2. Introduced using 'test-group'"
  491. '(() () () () () (0 0 0 0 1))
  492. (triv-runner
  493. (lambda ()
  494. (test-begin "a")
  495. (test-skip "b")
  496. (test-group
  497. "b" ; skipped
  498. (test-assert "x" #t))
  499. (test-end "a"))))
  500. (test-equal
  501. "6.4.3.3. Non-skipped 'test-group'"
  502. '(("x") () () () () (1 0 0 0 0))
  503. (triv-runner
  504. (lambda ()
  505. (test-begin "a")
  506. (test-skip "c")
  507. (test-group "b" (test-assert "x" #t))
  508. (test-end "a"))))
  509. (test-end) ; 6.4.3
  510. (test-end);6.4
  511. (test-end "6. Skipping selected tests")
  512. ;;;
  513. ;;;
  514. ;;;
  515. (test-begin "7. Expected failures")
  516. (test-equal "7.1. Simple example"
  517. '(() ("x") ("z") () () (0 1 1 0 0))
  518. (triv-runner
  519. (lambda ()
  520. (test-assert "x" #f)
  521. (test-expect-fail "z")
  522. (test-assert "z" #f))))
  523. (test-equal "7.2. Expected exception"
  524. '(() ("x") ("z") () () (0 1 1 0 0))
  525. (triv-runner
  526. (lambda ()
  527. (test-assert "x" #f)
  528. (test-expect-fail "z")
  529. (test-assert "z" (choke)))))
  530. (test-equal "7.3. Unexpectedly PASS"
  531. '(() () ("y") ("x") () (0 0 1 1 0))
  532. (triv-runner
  533. (lambda ()
  534. (test-expect-fail "x")
  535. (test-expect-fail "y")
  536. (test-assert "x" #t)
  537. (test-assert "y" #f))))
  538. (test-end "7. Expected failures")
  539. ;;;
  540. ;;;
  541. ;;;
  542. (test-begin "8. Test-runner")
  543. ;;;
  544. ;;; Because we want this test suite to be accurate even
  545. ;;; when the underlying implementation chooses to use, e.g.,
  546. ;;; a global variable to implement what could be thread variables
  547. ;;; or SRFI-39 parameter objects, we really need to save and restore
  548. ;;; their state ourselves
  549. ;;;
  550. (define (with-factory-saved thunk)
  551. (let* ((saved (test-runner-factory))
  552. (result (thunk)))
  553. (test-runner-factory saved)
  554. result))
  555. (test-begin "8.1. test-runner-current")
  556. (test-assert "8.1.1. automatically restored"
  557. (let ((a 0)
  558. (b 1)
  559. (c 2))
  560. ;
  561. (triv-runner
  562. (lambda ()
  563. (set! a (test-runner-current))
  564. ;;
  565. (triv-runner
  566. (lambda ()
  567. (set! b (test-runner-current))))
  568. ;;
  569. (set! c (test-runner-current))))
  570. ;;
  571. (and (eq? a c)
  572. (not (eq? a b)))))
  573. (test-end)
  574. (test-begin "8.2. test-runner-simple")
  575. ;; Procedure equality is explicitly unspecified by R6RS.
  576. ;; (test-assert "8.2.1. default on-test hook"
  577. ;; (eq? (test-runner-on-test-end (test-runner-simple))
  578. ;; test-on-test-end-simple))
  579. ;; (test-assert "8.2.2. default on-final hook"
  580. ;; (eq? (test-runner-on-final (test-runner-simple))
  581. ;; test-on-final-simple))
  582. (test-end)
  583. (test-begin "8.3. test-runner-factory")
  584. ;; Procedure equality is explicitly unspecified by R6RS.
  585. ;; (test-assert "8.3.1. default factory"
  586. ;; (eq? (test-runner-factory) test-runner-simple))
  587. (test-assert "8.3.2. settable factory"
  588. (with-factory-saved
  589. (lambda ()
  590. (test-runner-factory test-runner-null)
  591. ;; we have no way, without bringing in other SRFIs,
  592. ;; to make sure the following doesn't print anything,
  593. ;; but it shouldn't:
  594. (test-with-runner
  595. (test-runner-create)
  596. (lambda ()
  597. (test-begin "a")
  598. (test-assert #t) ; pass
  599. (test-assert #f) ; fail
  600. (test-assert (vector-ref '#(3) 10)) ; fail with error
  601. (test-end "a")))
  602. (eq? (test-runner-factory) test-runner-null))))
  603. (test-end)
  604. ;;; This got tested about as well as it could in 8.3.2
  605. (test-begin "8.4. test-runner-create")
  606. (test-end)
  607. ;;; This got tested about as well as it could in 8.3.2
  608. (test-begin "8.5. test-runner-factory")
  609. (test-end)
  610. (test-begin "8.6. test-apply")
  611. (test-equal "8.6.1. Simple (form 1) test-apply"
  612. '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
  613. (triv-runner
  614. (lambda ()
  615. (test-begin "a")
  616. (test-assert "w" #t)
  617. (test-apply
  618. (test-match-name "p")
  619. (lambda ()
  620. (test-begin "p")
  621. (test-assert "x" #t)
  622. (test-end)
  623. (test-begin "z")
  624. (test-assert "p" #t) ; only this one should execute in here
  625. (test-end)))
  626. (test-assert "v" #t))))
  627. (test-equal "8.6.2. Simple (form 2) test-apply"
  628. '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
  629. (triv-runner
  630. (lambda ()
  631. (test-begin "a")
  632. (test-assert "w" #t)
  633. (test-apply
  634. (test-runner-current)
  635. (test-match-name "p")
  636. (lambda ()
  637. (test-begin "p")
  638. (test-assert "x" #t)
  639. (test-end)
  640. (test-begin "z")
  641. (test-assert "p" #t) ; only this one should execute in here
  642. (test-end)))
  643. (test-assert "v" #t))))
  644. (test-expect-fail 1) ;; depends on all test-match-nth being called.
  645. (test-equal "8.6.3. test-apply with skips"
  646. '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
  647. (triv-runner
  648. (lambda ()
  649. (test-begin "a")
  650. (test-assert "w" #t)
  651. (test-skip (test-match-nth 2))
  652. (test-skip (test-match-nth 4))
  653. (test-apply
  654. (test-runner-current)
  655. (test-match-name "p")
  656. (test-match-name "q")
  657. (lambda ()
  658. ; only execute if SKIP=no and APPLY=yes
  659. (test-assert "x" #t) ; # 1 SKIP=no APPLY=no
  660. (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes
  661. (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes
  662. (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no
  663. 0))
  664. (test-assert "v" #t))))
  665. ;;; Unfortunately, since there is no way to UNBIND the current test runner,
  666. ;;; there is no way to test the behavior of `test-apply' in the absence
  667. ;;; of a current runner within our little meta-test framework.
  668. ;;;
  669. ;;; To test the behavior manually, you should be able to invoke:
  670. ;;;
  671. ;;; (test-apply "a" (lambda () (test-assert "a" #t)))
  672. ;;;
  673. ;;; from the top level (with SRFI 64 available) and it should create a
  674. ;;; new, default (simple) test runner.
  675. (test-end)
  676. ;;; This entire suite depends heavily on 'test-with-runner'. If it didn't
  677. ;;; work, this suite would probably go down in flames
  678. (test-begin "8.7. test-with-runner")
  679. (test-end)
  680. ;;; Again, this suite depends heavily on many of the test-runner
  681. ;;; components. We'll just test those that aren't being exercised
  682. ;;; by the meta-test framework
  683. (test-begin "8.8. test-runner components")
  684. (define (auxtrack-runner thunk)
  685. (let ((r (test-runner-null)))
  686. (test-runner-aux-value! r '())
  687. (test-runner-on-test-end! r (lambda (r)
  688. (test-runner-aux-value!
  689. r
  690. (cons (test-runner-test-name r)
  691. (test-runner-aux-value r)))))
  692. (test-with-runner r (thunk))
  693. (reverse (test-runner-aux-value r))))
  694. (test-equal "8.8.1. test-runner-aux-value"
  695. '("x" "" "y")
  696. (auxtrack-runner
  697. (lambda ()
  698. (test-assert "x" #t)
  699. (test-begin "a")
  700. (test-assert #t)
  701. (test-assert "y" #f)
  702. (test-end))))
  703. (test-end) ; 8.8
  704. (test-end "8. Test-runner")
  705. (test-begin "9. Test Result Properties")
  706. (test-begin "9.1. test-result-alist")
  707. (define (symbol-alist? l)
  708. (if (null? l)
  709. #t
  710. (and (pair? l)
  711. (pair? (car l))
  712. (symbol? (caar l))
  713. (symbol-alist? (cdr l)))))
  714. ;;; check the various syntactic forms
  715. (test-assert (symbol-alist?
  716. (car (on-test-runner
  717. (lambda ()
  718. (test-assert #t))
  719. (lambda (r)
  720. (test-result-alist r))))))
  721. (test-assert (symbol-alist?
  722. (car (on-test-runner
  723. (lambda ()
  724. (test-assert #t))
  725. (lambda (r)
  726. (test-result-alist r))))))
  727. ;;; check to make sure the required properties are returned
  728. (test-equal '((result-kind . pass))
  729. (prop-runner
  730. '(result-kind)
  731. (lambda ()
  732. (test-assert #t)))
  733. )
  734. (test-equal
  735. '((result-kind . fail)
  736. (expected-value . 2)
  737. (actual-value . 3))
  738. (prop-runner
  739. '(result-kind expected-value actual-value)
  740. (lambda ()
  741. (test-equal 2 (+ 1 2)))))
  742. (test-end "9.1. test-result-alist")
  743. (test-begin "9.2. test-result-ref")
  744. (test-equal '(pass)
  745. (on-test-runner
  746. (lambda ()
  747. (test-assert #t))
  748. (lambda (r)
  749. (test-result-ref r 'result-kind))))
  750. (test-equal '(pass)
  751. (on-test-runner
  752. (lambda ()
  753. (test-assert #t))
  754. (lambda (r)
  755. (test-result-ref r 'result-kind))))
  756. (test-equal '(fail pass)
  757. (on-test-runner
  758. (lambda ()
  759. (test-assert (= 1 2))
  760. (test-assert (= 1 1)))
  761. (lambda (r)
  762. (test-result-ref r 'result-kind))))
  763. (test-end "9.2. test-result-ref")
  764. (test-begin "9.3. test-result-set!")
  765. (test-equal '(100 100)
  766. (on-test-runner
  767. (lambda ()
  768. (test-assert (= 1 2))
  769. (test-assert (= 1 1)))
  770. (lambda (r)
  771. (test-result-set! r 'foo 100)
  772. (test-result-ref r 'foo))))
  773. (test-end "9.3. test-result-set!")
  774. (test-end "9. Test Result Properties")
  775. ;;;
  776. ;;;
  777. ;;;
  778. #| Time to stop having fun...
  779. (test-begin "9. For fun, some meta-test errors")
  780. (test-equal
  781. "9.1. Really PASSes, but test like it should FAIL"
  782. '(() ("b") () () ())
  783. (triv-runner
  784. (lambda ()
  785. (test-assert "b" #t))))
  786. (test-expect-fail "9.2. Expect to FAIL and do so")
  787. (test-expect-fail "9.3. Expect to FAIL but PASS")
  788. (test-skip "9.4. SKIP this one")
  789. (test-assert "9.2. Expect to FAIL and do so" #f)
  790. (test-assert "9.3. Expect to FAIL but PASS" #t)
  791. (test-assert "9.4. SKIP this one" #t)
  792. (test-end)
  793. |#
  794. (test-end "SRFI 64 - Meta-Test Suite")
  795. ;;;