Skip to content

[WIP]Test upgrade #261

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 2 commits into from
Closed

[WIP]Test upgrade #261

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
659ea8b
Get test-util.ss
guygastineau Jun 8, 2022
3b5a202
Migrated collatz-conjecture to new test system.
guygastineau Jun 9, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
162 changes: 162 additions & 0 deletions exercises/practice/collatz-conjecture/test-util.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,162 @@
(import (except (rnrs) current-output-port))

(define test-fields '(input expected actual))

(define (test-run-solution solution input)
(if (procedure? solution) (apply solution input) solution))

(define (scheme->string o)
(with-output-to-string
(lambda ()
(write o))))

(define (process-condition e)
(if (not (condition? e)) e
`(error
,(if (who-condition? e) (condition-who e)
'unknown)
,(condition-message e)
,@(if (not (irritants-condition? e)) '()
(condition-irritants e)))))

(define (test-success description success-predicate
procedure input expected code)
(call/cc
(lambda (k)
(let ([out (open-output-string)])
(dynamic-wind
(lambda () (set! out (open-output-string)))
(lambda ()
(with-exception-handler
(lambda (e)
(k `(fail
(description . ,description)
(code . ,code)
(input . ,input)
(expected . ,expected)
(actual . ,(process-condition e))
(stdout . ,(get-output-string out)))))
(lambda ()
(let ([result (parameterize ([current-output-port out])
(test-run-solution procedure input))])
(unless (success-predicate result expected)
(raise result))
`(pass
(description . ,description)
(code . ,code)
(stdout . ,(get-output-string out)))))))
(lambda () (close-output-port out)))))))

(define (test-error description procedure input code)
(call/cc
(lambda (k)
(let ([out '()])
(dynamic-wind
(lambda () (set! out (open-output-string)))
(lambda ()
(with-exception-handler
(lambda (e)
(k `(pass
(description . ,description)
(code . ,code)
(stdout . ,(get-output-string out)))))
(lambda ()
(let ((result (parameterize ([current-output-port out])
(test-run-solution procedure input))))
`(fail
(description . ,description)
(code . ,code)
(input . ,input)
(expected . error)
(actual . ,result)
(stdout . ,(get-output-string out)))))))
(lambda () (close-output-port out)))))))

(define (run-test test)
(eval (append test `((quote ,test))) (interaction-environment)))

(define (run-test-suite tests . query)
(for-each
(lambda (field)
(unless (and (symbol? field) (memq field test-fields))
(error 'run-test-suite
(format #t "~a not in ~a" field test-fields))))
query)
(let-values ([(passes failures)
(partition
(lambda (result) (eq? 'pass (car result)))
(map run-test tests))])
(cond
[(null? failures) (format #t "~%Well done!~%~%")]
[else
(format
#t
"~%Passed ~a/~a tests.~%~%The following test cases failed:~%~%"
(length passes)
(length tests))
(for-each
(lambda (failure)
(format
#t
"* ~a~%"
(cond
[(assoc 'description (cdr failure)) => cdr]
[else (cdr failure)]))
(for-each
(lambda (field)
(let ([info (assoc field (cdr failure))])
(display " - ")
(write (car info))
(display ": ")
(write (cdr info))
(newline)))
query))
failures)
(error 'test "incorrect solution")])))


(define (run-docker suite)
(write (map run-test suite)))

(define (test suite . query)
(apply run-test-suite suite query))

(define (tests suites . query)
(for-each (lambda (suite) (apply test suite query)) suites))

(define (run-with-cli solution suites)
(let ((args (command-line)))
(cond
;; Normal execution. This is the default behavior used by students
;; running their tests locally.
[(null? (cdr args))
(load solution)
(tests suites 'input 'expected 'actual)]
;; Scheme programs ingesting this output can expect an alist with
;; the keys 'test-lib-version and 'status. No test-lib version
;; means an older version of these test utilities is in use, so there
;; will only be pass/fail lists in the output. When status is 'error,
;; A message is provided for explanation. It is usually a stringified
;; condition. When status is 'completed everything is normal, and the
;; rest of the list comsists of pass/fail lists.
[(string=? (cadr args) "--docker")
(write
`((test-lib-version . 1)
,@(call/cc
(lambda (k)
(with-exception-handler
;; Catch failures while loading/compiling the solution.
(lambda (e)
(k `((status . error)
(message
. ,(string-append
"Failed with value: "
(scheme->string (process-condition e)))))))
(lambda ()
(load solution)
`((status . ok)
,@(fold-left (lambda (results suite)
(append results (map run-test suite)))
'() suites))))))))]
;; You can pass the name of a file to load instead of the "expected" solution filename.
[else (load (cadr args)) (tests suites 'input 'expected)])))
132 changes: 7 additions & 125 deletions exercises/practice/collatz-conjecture/test.scm
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,128 +1,10 @@
(import (except (rnrs) current-output-port))

(define test-fields '(input output))

(define (test-run-solution solution input)
(if (procedure? solution) (apply solution input) solution))

(define (test-success description success-predicate
procedure input output)
(call/cc
(lambda (k)
(let ([out (open-output-string)])
(with-exception-handler
(lambda (e)
(let ([result `(fail
(description . ,description)
(input . ,input)
(output . ,output)
(stdout . ,(get-output-string out)))])
(close-output-port out)
(k result)))
(lambda ()
(let ([result (parameterize ([current-output-port out])
(test-run-solution procedure input))])
(unless (success-predicate result output)
(error 'exercism-test
"test fails"
description
input
result
output)))
(let ([result `(pass
(description . ,description)
(stdout . ,(get-output-string out)))])
(close-output-port out)
result)))))))

(define (test-error description procedure input)
(call/cc
(lambda (k)
(let ([out (open-output-string)])
(with-exception-handler
(lambda (e)
(let ([result `(pass
(description . ,description)
(stdout . ,(get-output-string out)))])
(close-output-port out)
(k result)))
(lambda ()
(parameterize ([current-output-port out])
(test-run-solution procedure input))
(let ([result `(fail
(description . ,description)
(input . ,input)
(output . error)
(stdout . ,(get-output-string out)))])
(close-output-port out)
result)))))))

(define (run-test-suite tests . query)
(for-each
(lambda (field)
(unless (and (symbol? field) (memq field test-fields))
(error 'run-test-suite
(format #t "~a not in ~a" field test-fields))))
query)
(let-values ([(passes failures)
(partition
(lambda (result) (eq? 'pass (car result)))
(map (lambda (test) (test)) tests))])
(cond
[(null? failures) (format #t "~%Well done!~%~%")]
[else
(format
#t
"~%Passed ~a/~a tests.~%~%The following test cases failed:~%~%"
(length passes)
(length tests))
(for-each
(lambda (failure)
(format
#t
"* ~a~%"
(cond
[(assoc 'description (cdr failure)) => cdr]
[else (cdr failure)]))
(for-each
(lambda (field)
(let ([info (assoc field (cdr failure))])
(display " - ")
(write (car info))
(display ": ")
(write (cdr info))
(newline)))
query))
failures)
(error 'test "incorrect solution")])))

(define (run-docker test-cases)
(write (map (lambda (test) (test)) test-cases)))

(define collatz)
(load "test-util.ss")

(define test-cases
(list
(lambda ()
(test-success "zero steps for one" = collatz '(1) 0))
(lambda ()
(test-success "divide if even" = collatz '(16) 4))
(lambda ()
(test-success "even and odd steps" = collatz '(12) 9))
(lambda ()
(test-success "large number of even and odd steps" = collatz
'(1000000) 152))))

(define (test . query)
(apply run-test-suite test-cases query))

(let ([args (command-line)])
(cond
[(null? (cdr args))
(load "collatz-conjecture.scm")
(test 'input 'output)]
[(string=? (cadr args) "--docker")
(load "collatz-conjecture.scm")
(run-docker test-cases)]
[else (load (cadr args)) (test 'input 'output)]))
`((test-success "zero steps for one" = collatz '(1) 0)
(test-success "divide if even" = collatz '(16) 4)
(test-success "even and odd steps" = collatz '(12) 9)
(test-success "large number of even and odd steps" = collatz
'(1000000) 152)))

(run-with-cli "collatz-conjecture.scm" `(,test-cases))
Loading