-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdrracket-init.scm
109 lines (93 loc) · 4.3 KB
/
drracket-init.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
107
108
109
(module drracket-init mzscheme
(require (lib "pretty.ss"))
(require (lib "trace.ss"))
(provide (all-from (lib "pretty.ss")))
(provide (all-from (lib "trace.ss")))
(provide make-parameter
;
run-experiment
run-tests!
; setting options
stop-after-first-error
run-quietly
)
; makes structs printable,
; provides basic functionality for testing. This includes pretty-printing and tracing.
; ============================================================================
; show the contents of define-datatype values
(print-struct #t)
; safely apply procedure fn to a list of args.
; 1. if successful, return (cons #t val)
; 2. if eopl:error is invoked, returns (cons #f string), where string is the format string generated by eopl:error.
; 3. If somebody manages to raise a value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
; run-experiment :: (Args -> b) -> Args -> b -> (b -> b -> bool) -> (cons bool b)
; usage: (run-experiment fn args correct-answer equal-answer?)
; Applies fn to args.
; Compares the result to correct-answer.
; Returns (cons bool b) where bool indicates whether the answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let* [(result (apply-safely fn args))
(error-thrown? (not (car result)))
(ans (cdr result))] ; ans is either the answer or the args to eopl:error
(cons (if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
; make-parameter : 专门用于"setting options"
; (define setting (make-parameter #f)
; ====> if (setting) 得到 #f
; ====> (setting #t) ; if (setting) 得到 #t
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test) -> unspecified
; usage: (run-tests! run-fn equal-answer? tests)
; where:
; test ::= (name arg outcome)
; outcome ::= ERROR | any
; for each item in tests, apply run-fn to the arg.
; Check to see ifthe outcome is right, comparing values using equal-answer?.
; print a log of the tests.
; at the end, print either "no bugs found" or the list of tests failed.
; Normally, run-tests! will recover from any error and continue to the end of the test suite.
; This behavior can be altered by setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((failed-tests '()))
(for-each
(lambda (test-item)
(let [(name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item))]
(printf "test: ~a~%" name)
(let* [(result (run-experiment run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result))]
(if (or (not correct?) (not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
; stop on first error if stop-after-first? is set:
(if (stop-after-first-error) (error name "incorrect outcome detected"))
(set! failed-tests (cons name failed-tests)))))))
tests)
(if (null? failed-tests)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse failed-tests)))))
)