-
Notifications
You must be signed in to change notification settings - Fork 130
/
bunny-test.scm
106 lines (88 loc) · 2.79 KB
/
bunny-test.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
; Bunny-Unit
(define (test code)
(list 'bunny-test
code
'bunny-test:un-tested))
(define (bunny-test? t)
(and (list? t)
(eq? (car t) 'bunny-test)))
(define (get-code t)
(if (bunny-test? t)
(cadr t)))
(define (get-test-result t)
(if (bunny-test? t)
(begin
(if (not (test-execed? t))
(exec-test t))
(caddr t))))
(define (test-execed? t)
(not (equal? 'bunny-test:un-tested
(caddr t))))
(define (exec-test t)
(set-car! (cddr t)
(eval (get-code t))))
(define (test-failed? t)
(if (bunny-test? t)
(not (get-test-result t))))
(define (test-passed? t)
(and (bunny-test? t)
(get-test-result t)))
(define (test-suite name . tests)
(list 'bunny-suite
name
tests))
(define (bunny-suite? b)
(and (list? b)
(eq? 'bunny-suite (car b))))
(define (get-suite-name b)
(if (bunny-suite? b)
(cadr b)))
(define (get-suite-tests b)
(if (bunny-suite? b)
(caddr b)))
(define (display-suite s)
(newline)
(display "Suite: ")
(display (get-suite-name s))
(for-each (lambda (t) (test-report t))
(get-suite-tests s)))
(define (display-passed-test t)
(display "."))
(define (display-failed-test t)
(newline)
(display "Failed: ")
(display (get-code t))
(newline))
(define (test-report item . depth)
(cond
((bunny-suite? item)
(display-suite item))
((and (bunny-test? item)
(test-failed? item))
(display-failed-test item))
((and (bunny-test? item)
(test-passed? item))
(display-passed-test item))
(else
(error "No test or suite passed to report!"))))
(define (test-tests)
(test-suite 'Test-Tests
(test '(bunny-test? (test '#t)))
(test '(not(bunny-test? #f)))
(test '(equal? (get-code (test 'some-code)) 'some-code))
(test '(get-test-result (test #t)))
(test '(not(get-test-result (test #f))))
(let ((t (test '#t)))
(test (not (test-execed? t)))
(test (get-test-result t))
(test (test-execed? t)))))
(define (suite-tests)
(test-suite 'Suite-Tests
(test '(bunny-suite? (test-suite 'dummy (test #t) (test #f))))
(test '(equal? (get-suite-name (test-suite 'dummy (test #t))) 'dummy))
(test '(bunny-test? (car (get-suite-tests (test-suite 'dummy (test #t))))))
(test '(bunny-suite? (cadr (get-suite-tests (test-suite 'dummy (test #t) (test-suite 'inner-dummy))))))))
(define (all-tests)
(test-suite 'All-Tests
(test-tests)
(suite-tests)))