399 lines
12 KiB
Scheme
399 lines
12 KiB
Scheme
; A testing framework
|
|
;
|
|
; Independent of PIKA except for pika_message,
|
|
; which you can redefine
|
|
|
|
|
|
; Testing language
|
|
|
|
; AssertStmt ~ (assert '(<code>))
|
|
; AssertErrorStmt ~ (assert-error '(<code>) <prefix of expected error string>)
|
|
; ReportStmt ~ (testing:report)
|
|
; LoadStmt ~ (testing:load-test <filename>)
|
|
; AllPassedPredicate ~ (testing:all-passed?)
|
|
;
|
|
; AssertStmt and AssertErrorStmt have side effects on the testing state,
|
|
; and the other statements yield or display the state.
|
|
;
|
|
; AssertStmt and AssertErrorStmt also have side effects on the display,
|
|
; displaying failures.
|
|
;
|
|
; AssertStmt and AssertErrorStmt also yield #t or #f
|
|
; meaning pass or fail.
|
|
|
|
|
|
; Syntax errors
|
|
|
|
; The test framework WILL NOT handle syntax errors.
|
|
; The quoted code under tests must parse without syntax errors.
|
|
; Some errors that TinyScheme throws ARE syntax errors, but not named such.
|
|
; For example '#\xzzz is a syntax error (z is not a hex digit).
|
|
; Thus the test framework won't handle '#\xzzz .
|
|
|
|
|
|
; Algebra of calls
|
|
;
|
|
; Typically one or more AssertStmt followed by a ReportStmt
|
|
; when viewed in the console.
|
|
; Or one or more AssertStmt followed by AllPassedPredicate
|
|
; to yield an overall testing result,
|
|
; when testing is automated.
|
|
|
|
; Testing error messages
|
|
;
|
|
; Error messages may have details such as line number of error
|
|
; that may change over time.
|
|
; Testing expects that details will be a suffix of the error message.
|
|
; Passing is measured by comparing given expected prefix of error
|
|
; with actual error message.
|
|
|
|
|
|
; Notes on implementation:
|
|
;
|
|
; Debug stream for testing is pika-message
|
|
|
|
|
|
; EvalResult object
|
|
; is-a tuple (result, error)
|
|
; <result> is dynamic type returned by eval
|
|
; <error> is type string
|
|
|
|
(define (make-evalresult result errors)
|
|
;(pika-message "make-evalresult")
|
|
(list result errors))
|
|
(define (evalresult-get-result x) (car x))
|
|
(define (evalresult-get-error x) (cadr x))
|
|
(define (evalresult-has-no-error? x)
|
|
(= (string-length (cadr x)) 0))
|
|
|
|
|
|
; state
|
|
|
|
(define testing:passed 0) ; counter
|
|
(define testing:failed '()) ; list
|
|
|
|
(define (testing:reset!)
|
|
(set! testing:passed 0)
|
|
(set! testing:failed '()))
|
|
|
|
(define (testing:log-passed!)
|
|
; Not announce success to console, but can debug
|
|
(pika-message "Passed")
|
|
(set! testing:passed (+ testing:passed 1)))
|
|
|
|
; log any failure
|
|
(define (testing:log-fail! failure-string)
|
|
; Announce fail as it happens
|
|
(displayln "")
|
|
(display "Failed: ")
|
|
(displayln failure-string)
|
|
; save in state: prepend to list of failures
|
|
(set! testing:failed
|
|
(cons failure-string
|
|
testing:failed)))
|
|
|
|
|
|
(define (testing:log-fail-assert! code eval-result)
|
|
(testing:log-fail! (testing:format-fail-assert code eval-result)))
|
|
|
|
(define (testing:log-fail-assert-error! code actual-error expected-error)
|
|
(testing:log-fail! (testing:format-fail-assert-error
|
|
code
|
|
actual-error
|
|
expected-error)))
|
|
|
|
; reset testing state when test framework is loaded
|
|
(testing:reset!)
|
|
|
|
|
|
|
|
; reporting
|
|
; These methods encapsulate formatting of strings and reports
|
|
|
|
; A report is a summary of counts
|
|
; followed by line for each failure
|
|
(define (testing:report)
|
|
(testing:display-summary)
|
|
(testing:display-fails))
|
|
|
|
(define (testing:display-summary)
|
|
(displayln "")
|
|
(display "Passed: ")
|
|
(display testing:passed)
|
|
(display " Failed: ")
|
|
(displayln (length testing:failed)))
|
|
|
|
; Display list of failures in time order
|
|
; This does not iterate over the list.
|
|
; It relies on newlines in the individual failure formats.
|
|
(define (testing:display-fails)
|
|
(if (> (length testing:failed) 0)
|
|
(begin
|
|
(displayln "Failures:")
|
|
; reverse list so it displays in time order
|
|
(display (reverse testing:failed)))
|
|
'()))
|
|
|
|
; returns a string for failed assert-error
|
|
; Of form: Code: foo Actual: bar Expected: zed
|
|
(define (testing:format-fail-assert-error code actual-error expected-error)
|
|
(string-append
|
|
"<Code> "
|
|
(any->string code)
|
|
(string #\newline)
|
|
" <Actual> "
|
|
actual-error
|
|
(string #\newline)
|
|
" <Expected> "
|
|
expected-error
|
|
(string #\newline)
|
|
(string #\newline))
|
|
)
|
|
|
|
; returns a string for failed assert
|
|
; Of form Code: foo Error: bar
|
|
(define (testing:format-fail-assert code eval-result)
|
|
(string-append
|
|
"<Code>"
|
|
(any->string code)
|
|
(string #\newline)
|
|
; Any error message.
|
|
"<Error>"
|
|
(evalresult-get-error eval-result)
|
|
(string #\newline)
|
|
(string #\newline)
|
|
; We don't display result, it must be false
|
|
; because were given a boolean proposition
|
|
)
|
|
)
|
|
|
|
|
|
; boolean result for entire testing session
|
|
|
|
(define (testing:all-passed? )
|
|
(not (= (length testing:failed) 0)))
|
|
|
|
|
|
|
|
; Record eval-result, a tuple, from eval of code.
|
|
; This knows that a passed normal test has true result and empty error.
|
|
; <code is> a an object? a Scheme text, is a boolean proposition,
|
|
(define (testing:record-assert-result eval-result code)
|
|
;(pika-message "record-assert-result")
|
|
; passed when has no error and result is #t
|
|
(if (and (evalresult-has-no-error? eval-result)
|
|
(evalresult-get-result eval-result))
|
|
(testing:log-passed!)
|
|
; fail
|
|
(testing:log-fail-assert!
|
|
code
|
|
eval-result)))
|
|
|
|
; Record eval-result, a tuple, from eval of code.
|
|
; This knows that a passed assert-error test has don't care result.
|
|
; Instead, this knows the test passes if given <expected-error>
|
|
; matches a prefix of the actual error message yielded by eval.
|
|
; <result> is dynamic type returned by eval
|
|
; <error-message> is type string
|
|
; <code> is a an object? a Scheme text, is a boolean proposition.
|
|
; <expected-error> is type string
|
|
(define (testing:record-assert-error-result eval-result code expected-error)
|
|
; debug
|
|
;(displayln "record-assert-error-result")
|
|
;(displayln eval-result)
|
|
|
|
; expected error string a prefix of actual error string?
|
|
(if (string-prefix?
|
|
expected-error
|
|
(evalresult-get-error eval-result))
|
|
; passed
|
|
(begin
|
|
(testing:log-passed!)
|
|
#t)
|
|
; fail, pass asserted code, actual error, expected error
|
|
(begin
|
|
(testing:log-fail-assert-error!
|
|
code
|
|
(evalresult-get-error eval-result)
|
|
expected-error)
|
|
#f)))
|
|
|
|
; Strict equality of error strings:
|
|
;(if (equal?
|
|
; (evalresult-get-error eval-result)
|
|
; expected-error)
|
|
|
|
|
|
; Statments in the testing DSL.
|
|
|
|
; The usual or normal test.
|
|
; <code> is a boolean proposition expected to yield #t
|
|
(define (assert code)
|
|
(let* ((eval-result (harnessed-eval code)))
|
|
; eval-result is tuple
|
|
; record normal result i.e. error not expected
|
|
(testing:record-assert-result
|
|
eval-result
|
|
code)
|
|
; Statements have side-effect on testing state,
|
|
; but also return boolean result of predicate.
|
|
(evalresult-get-result eval-result )))
|
|
|
|
; A test of abnormality.
|
|
; <code> is not expected to yield any particular value
|
|
; <error> is a prefix of error string that <code> is expected to throw.
|
|
(define (assert-error code expected-error)
|
|
(let* ((eval-result (harnessed-eval code)))
|
|
; eval-result is tuple
|
|
; record normal result i.e. error not expected
|
|
(testing:record-assert-error-result
|
|
eval-result
|
|
code
|
|
expected-error)
|
|
; Returns whether error matches expected error prefix.
|
|
))
|
|
|
|
|
|
; eval code, returning tuple of result and errors
|
|
; This knows how to capture errors
|
|
; but not what result and errors mean for testing.
|
|
; Harnessed means: surrounded by code to capture error messages.
|
|
;
|
|
; Assert the pre-condition *error-hook* is (throw msg) see script-fu.init.
|
|
; So any call (error msg) is (throw msg)
|
|
; But we are not using (catch handler code).
|
|
; We are only overriding *error-hook*
|
|
;
|
|
; Any given eval of code under test may yield many calls to the error hook.
|
|
; We only record the first error message in an eval of the code under test.
|
|
|
|
(define (harnessed-eval code)
|
|
;(pika-message "harnessed-eval")
|
|
(let* ((old-error-hook *error-hook*) ; save original handler, which is throw
|
|
(errors "") ; initial empty string
|
|
(result #f) ; initial result is #f, not () which is truthy
|
|
|
|
(testing-error-hook
|
|
(lambda (xs)
|
|
;(pika-message "testing-error-hook")
|
|
|
|
; Only record the first error
|
|
(if (= (string-length errors) 0)
|
|
(if (string? xs)
|
|
(begin
|
|
;(pika-message "xs is string")
|
|
(set! errors xs))
|
|
(set! errors "Non-string error")))
|
|
|
|
; Do not chain up to old handler: (old-error-hook xs)
|
|
; Old handler is usually throw, which is error,
|
|
; and that infinite loops
|
|
;
|
|
; This returns to current eval,
|
|
; which may call this error hook again.
|
|
;(pika-message "returning from error hook")
|
|
)))
|
|
;(pika-message "override error hook")
|
|
(set! *error-hook* testing-error-hook)
|
|
;(pika-message "eval test code")
|
|
(set! result (eval code))
|
|
;(pika-message "restore error hook")
|
|
; restore the error hook for any code in a test script between asserts
|
|
(set! *error-hook* old-error-hook)
|
|
; return an EvalResult
|
|
(make-evalresult result errors)))
|
|
|
|
|
|
|
|
|
|
|
|
; port utility
|
|
|
|
|
|
(define (with-string open-function str function)
|
|
(let ((port (open-function str)))
|
|
(if (port? port)
|
|
(let ((result '()))
|
|
(set! result (function port))
|
|
(close-port port)
|
|
result)
|
|
; Testing internal error. Hijack the testing framework
|
|
(testing:log-fail! "Failed to open string for string port!" '() ))))
|
|
|
|
(define (call-with-output-string str function)
|
|
(with-string open-output-string str function))
|
|
|
|
|
|
|
|
; string utility
|
|
|
|
(define (trim char chars)
|
|
(if (= (char->integer char) (char->integer (car chars)))
|
|
(trim char (cdr chars))
|
|
chars))
|
|
|
|
(define (rtrim str)
|
|
(list->string (reverse (trim #\space (reverse (string->list str))))))
|
|
|
|
; any is code
|
|
; Not using atom->string. Using write
|
|
(define (any->string any)
|
|
(let* ((to-string
|
|
(lambda (any)
|
|
(let* ((str (make-string 256)))
|
|
(call-with-output-string str
|
|
(lambda (port) (write any port)))
|
|
str))))
|
|
(rtrim (to-string any))))
|
|
|
|
|
|
; string-prefix? is in R5RS but not tinyscheme.
|
|
; string-prefix? is in various SRFI's but we don't have them here
|
|
; So yet again, we need to implement it de novo
|
|
(define (string-prefix? str1 str2)
|
|
; if str1 is longer than str2, it is not a prefix
|
|
(if (> (string-length str1) (string-length str2))
|
|
#f
|
|
; else str2 is longer str2 than str1.
|
|
; str1 is a prefix if the leading substring of str2,
|
|
; that is the length of str1, equals str1.
|
|
(string=?
|
|
str1
|
|
(substring str2 0 (string-length str1)))))
|
|
|
|
|
|
|
|
; filesystem utility
|
|
|
|
; Return the fullpath of a test script.
|
|
; When fileScm is empty, returns path to dir of test scripts.
|
|
; From pika-data-directory i.e. the shared install dir for PIKA
|
|
; Require filename is string
|
|
; Require suffix, usually ".scm" on the filename
|
|
|
|
(define (path-to-test-scripts fileScm)
|
|
(let* ( (path (string-append pika-data-directory DIR-SEPARATOR "tests")))
|
|
(if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))
|
|
|
|
(define (path-to-test-images fileScm)
|
|
(let* ( (path (string-append pika-data-directory DIR-SEPARATOR "images")))
|
|
(if (zero? (string-length fileScm)) path (string-append path DIR-SEPARATOR fileScm))))
|
|
|
|
; load a test file, which executes it
|
|
; Knows where PIKA installs test scripts
|
|
;
|
|
; Subsequently, testing:report will say results
|
|
(define (testing:load-test filename)
|
|
(pika-message (path-to-test-scripts filename))
|
|
(load (path-to-test-scripts filename)))
|
|
|
|
; Tell Pika to load a test image
|
|
; Returns ID of image
|
|
; Knows installed image directory (not dedicated to testing but always there.)
|
|
; Accepts image suffixes that Pika can load.
|
|
; Typical is /usr/local/share/pika/2.99/images/wilber.png
|
|
(define (testing:load-test-image filename)
|
|
(pika-message (path-to-test-images filename))
|
|
; unpack ID via car
|
|
(car (pika-file-load RUN-NONINTERACTIVE (path-to-test-images filename))))
|
