diff --git a/Makefile b/Makefile index 4add912b..c2f13889 100644 --- a/Makefile +++ b/Makefile @@ -97,7 +97,11 @@ track : $(track-requirements) # send a list of implementations to run stub-makefile tests on ci : - echo "(run-ci '($(implementations)))" | $(chez) -q "script/ci.ss" + #echo "(run-ci '($(implementations)))" | $(chez) -q "script/ci.ss" + # The acronym example code only works for guile. Currently, examples + # must pass for both chez and guile. list-ops and robot-name are both + # deprecated anyway. + echo "(run-all-tests 'list-ops 'robot-name 'acronym)" | $(chez) -q script/ci.ss clean : find . -name "*.so" -exec rm {} \; diff --git a/code/test-migration.ss b/code/test-migration.ss new file mode 100644 index 00000000..0a282d42 --- /dev/null +++ b/code/test-migration.ss @@ -0,0 +1,136 @@ +(import (chezscheme)) + +(define (read-all-map-maybe p src) + (with-input-from-file src + (lambda () + (let rec ((ys '())) + (let ((x (read))) + (if (eof-object? x) ys + (let ((y (p x))) + (rec (if y (cons y ys) ys))))))))) + +(define (definition? x) + (and (list? x) + (>= (length x) 2) + (equal? (car x) 'define))) + +(define (stub? x) + (and (definition? x) (= (length x) 2))) + +(define (definition-name? name def) + (let ((ident (cadr def))) + (cond + ((symbol? ident) (equal? name ident)) + ((pair? ident) (equal? name (car ident))) + (else #f)))) + +(define (test-runner? x) + (and (list? x) (= 3 (length x)) + (equal? (car x) 'let) + (equal? (cadr x) '((args (command-line)))))) + +(define (legacy-import? x) + (equal? x '(import (except (rnrs) current-output-port)))) + +;; Predicate for things that should still be in the test.scm file. +;; This includes things we don't know about like extra predicates for the tests. +;; That is why it is defined in the negative. +(define (relevant? x) + (not (obsolete? x))) + +;; Predicate for all the things that shouldn't be in +;; the test.scm file anymore. +(define (obsolete? x) + (or (stub? x) + (test-runner? x) + (legacy-import? x) + (definition-name? 'test x) + (definition-name? 'run-docker x) + (definition-name? 'run-test-suite x) + (definition-name? 'test-error x) + (definition-name? 'test-success x) + (definition-name? 'test-run-solution x) + (definition-name? 'test-fields x))) + + +(define load-statement '(load "test-util.ss")) +(define (test-statement slug) + `(run-with-cli ,(format "~a.scm" slug) (list test-cases))) + +(define (migrate-test-cases cases) + (unless (definition-name? 'test-cases cases) + (error 'migrate-test-cases + "~s is not the test-cases definition" cases)) + `(define test-cases + ,(list 'quasiquote (map caddr (cdaddr cases))))) + +(define (cdr-or x y) + (if (pair? x) (cdr x) y)) + +;; We end up with 2 trailing newlines. +(define (migrate-file src . args) + (let ((slug (cdr-or (assoc 'slug args) 'solution)) + (body-parts + (read-all-map-maybe + (lambda (x) + (and (relevant? x) + (if (definition-name? 'test-cases x) + (migrate-test-cases x) + x))) + src))) + (delete-file src) + (with-output-to-file src + (lambda () + (for-each + (lambda (x) (pretty-print x) (newline)) + (cons load-statement + (reverse + (cons (test-statement slug) + body-parts)))))))) + +(define (slug->directory slug . args) + (let ((kind (cdr-or (assoc 'kind args) 'practice))) + (format "exercises/~a/~a/" kind slug))) + +(define (append-path base ext) + (unless (char=? #\/ (string-ref base (1- (string-length base)))) + (set! base (string-append base "/"))) + (format "~a~a" base ext)) + +(define (filename path) + (let ((last-sep-idx + (fold-left + (lambda (last x) + (or (and (char=? #\/ (cdr x)) (car x)) + last)) + #f (map cons (iota (string-length path)) + (string->list path))))) + (if (not last-sep-idx) path + (substring path (1+ last-sep-idx) (string-length path))))) + +(define (copy-file from to) + (when (file-directory? to) + (set! to (append-path to (filename from)))) + (when (file-exists? to) + (delete-file to)) + (with-input-from-file from + (lambda () + (with-output-to-file to + (lambda () + (do ((chunk (get-string-n (current-input-port) 1024) + (get-string-n (current-input-port) 1024))) + ((eof-object? chunk)) + (put-string (current-output-port) chunk))))))) + +(define (migrate-exercise slug . args) + (let* ((kind (cdr-or (assoc 'kind args) 'practice)) + (dir (slug->directory slug `(kind . ,kind)))) + (copy-file "input/test-util.ss" dir) + (migrate-file (append-path dir "test.scm") `(slug . ,slug)))) + +(define (deploy-new-test-util) + (for-each + (lambda (slug) + (copy-file "input/test-util.ss" + (slug->directory slug))) + (directory-list "exercises/practice/"))) diff --git a/config.json b/config.json index 59fd504c..f3cb59f4 100644 --- a/config.json +++ b/config.json @@ -23,7 +23,8 @@ "%{kebab_slug}.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ "example.scm" diff --git a/exercises/practice/accumulate/.meta/config.json b/exercises/practice/accumulate/.meta/config.json index e09b5d7d..01554c05 100644 --- a/exercises/practice/accumulate/.meta/config.json +++ b/exercises/practice/accumulate/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Implement the `accumulate` operation, which, given a collection and an operation to perform on each element of the collection, returns a new collection containing the result of applying that operation to each element of the input collection.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "accumulate.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Implement the `accumulate` operation, which, given a collection and an operation to perform on each element of the collection, returns a new collection containing the result of applying that operation to each element of the input collection.", "source": "Conversation with James Edward Gray II", "source_url": "https://twitter.com/jeg2" } diff --git a/exercises/practice/accumulate/test-util.ss b/exercises/practice/accumulate/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/accumulate/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/accumulate/test.scm b/exercises/practice/accumulate/test.scm index 368d1493..a453fa69 100644 --- a/exercises/practice/accumulate/test.scm +++ b/exercises/practice/accumulate/test.scm @@ -1,151 +1,43 @@ -(import (except (rnrs) current-output-port)) +(load "test-util.ss") -(define test-fields '(input output)) +(define (string-reverse s) + (list->string (reverse (string->list s)))) -(define (test-run-solution solution input) - (if (procedure? solution) (apply solution input) solution)) +(define (identity x) x) -(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 (string-join xs sep) + (if (null? xs) "" + (fold-left (lambda (r x) + (string-append r (string-append sep x))) + (car xs) (cdr xs)))) (define (square x) (* x x)) -(define accumulate) - (define test-cases - (list - (lambda () - (test-success "empty list" equal? accumulate `(,identity ()) '())) - (lambda () - (test-success "identity" equal? accumulate `(,identity (1 2 3)) '(1 2 3))) - (lambda () - (test-success "1+" equal? accumulate `(,1+ (1 2 3)) '(2 3 4))) - (lambda () - (test-success "squares" equal? accumulate `(,square (1 2 3)) '(1 4 9))) - (lambda () - (test-success "upcases" equal? accumulate - `(,string-upcase ("hello" "world")) '("HELLO" "WORLD"))) - (lambda () - (test-success - "reverse strings" equal? accumulate - `(,string-reverse ("the" "quick" "brown" "fox" "jumps" "over" "the" "lazy" "dog")) - '("eht" "kciuq" "nworb" "xof" "spmuj" "revo" "eht" "yzal" "god"))) - (lambda () - (test-success "length" equal? accumulate - `(,length ((a b c) (((d))) (e (f (g (h)))))) '(3 1 2))) - (lambda () - (test-success - "accumulate w/in accumulate" equal? accumulate - `(,(lambda (x) - (string-join - (accumulate (lambda (y) - (string-append x y)) - '("1" "2" "3")) - " ")) - ("a" "b" "c")) - '("a1 a2 a3" "b1 b2 b3" "c1 c2 c3"))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "accumulate.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "accumulate.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) - + '((test-success "empty list" equal? accumulate + `(,identity ()) '()) + (test-success "identity" equal? accumulate + `(,identity (1 2 3)) '(1 2 3)) + (test-success "1+" equal? accumulate `(,1+ (1 2 3)) + '(2 3 4)) + (test-success "squares" equal? accumulate `(,square (1 2 3)) + '(1 4 9)) + (test-success "upcases" equal? accumulate + `(,string-upcase ("hello" "world")) '("HELLO" "WORLD")) + (test-success "reverse strings" equal? accumulate + `(,string-reverse + ("the" "quick" "brown" "fox" "jumps" "over" "the" "lazy" + "dog")) + '("eht" "kciuq" "nworb" "xof" "spmuj" "revo" "eht" "yzal" + "god")) + (test-success "length" equal? accumulate + `(,length ((a b c) (((d))) (e (f (g (h)))))) '(3 1 2)) + (test-success "accumulate w/in accumulate" equal? accumulate + `(,(lambda (x) + (string-join + (accumulate (lambda (y) (string-append x y)) '("1" "2" "3")) + " ")) + ("a" "b" "c")) + '("a1 a2 a3" "b1 b2 b3" "c1 c2 c3")))) + +(run-with-cli "accumulate.scm" (list test-cases)) diff --git a/exercises/practice/acronym/.meta/config.json b/exercises/practice/acronym/.meta/config.json index ee96b433..8914a690 100644 --- a/exercises/practice/acronym/.meta/config.json +++ b/exercises/practice/acronym/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Convert a long phrase to its acronym", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "acronym.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Convert a long phrase to its acronym", "source": "Julien Vanier", "source_url": "https://github.com/monkbroc" } diff --git a/exercises/practice/acronym/test-util.ss b/exercises/practice/acronym/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/acronym/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/acronym/test.scm b/exercises/practice/acronym/test.scm index e22e4ddf..115f571f 100644 --- a/exercises/practice/acronym/test.scm +++ b/exercises/practice/acronym/test.scm @@ -1,148 +1,27 @@ -(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 acronym) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "basic" equal? acronym '("Portable Network Graphics") "PNG")) - (lambda () - (test-success "lowercase words" equal? acronym '("Ruby on Rails") "ROR")) - (lambda () - (test-success "punctuation" equal? acronym '("First In, First Out") "FIFO")) - (lambda () - (test-success - "all caps word" equal? acronym '("GNU Image Manipulation Program") "GIMP")) - (lambda () - (test-success "colon" equal? acronym '("PHP: Hypertext Preprocessor") "PHP")) - (lambda () - (test-success - "punctuation without whitespace" equal? acronym - '("Complementary metal-oxide semiconductor") "CMOS")) - (lambda () - (test-success - "very long abbreviation" equal? acronym - '("Rolling On The Floor Laughing So Hard That My Dogs Came Over And Licked Me") - "ROTFLSHTMDCOALM")) - (lambda () - (test-success - "consecutive delimiters" equal? acronym - '("Something - I made up from thin air") "SIMUFTA")) - (lambda () - (test-success "apostrophes" equal? acronym '("Halley's Comet") "HC")) - (lambda () - (test-success - "underscore emphasis" equal? acronym '("The Road _Not_ Taken") "TRNT")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "acronym.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "acronym.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "basic" equal? acronym + '("Portable Network Graphics") "PNG") + (test-success "lowercase words" equal? acronym + '("Ruby on Rails") "ROR") + (test-success "punctuation" equal? acronym + '("First In, First Out") "FIFO") + (test-success "all caps word" equal? acronym + '("GNU Image Manipulation Program") "GIMP") + (test-success "colon" equal? acronym + '("PHP: Hypertext Preprocessor") "PHP") + (test-success "punctuation without whitespace" equal? acronym + '("Complementary metal-oxide semiconductor") "CMOS") + (test-success "very long abbreviation" equal? acronym + '("Rolling On The Floor Laughing So Hard That My Dogs Came Over And Licked Me") + "ROTFLSHTMDCOALM") + (test-success "consecutive delimiters" equal? acronym + '("Something - I made up from thin air") "SIMUFTA") + (test-success "apostrophes" equal? acronym + '("Halley's Comet") "HC") + (test-success "underscore emphasis" equal? acronym + '("The Road _Not_ Taken") "TRNT"))) + +(run-with-cli "acronym.scm" (list test-cases)) diff --git a/exercises/practice/affine-cipher/.meta/config.json b/exercises/practice/affine-cipher/.meta/config.json index 4be11e60..9e7cfdce 100644 --- a/exercises/practice/affine-cipher/.meta/config.json +++ b/exercises/practice/affine-cipher/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Create an implementation of the Affine cipher, an ancient encryption algorithm from the Middle East.", "authors": [ "guygastineau" ], @@ -11,12 +10,14 @@ "affine-cipher.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Create an implementation of the Affine cipher, an ancient encryption algorithm from the Middle East.", "source": "Wikipedia", "source_url": "http://en.wikipedia.org/wiki/Affine_cipher" } diff --git a/exercises/practice/affine-cipher/test-util.ss b/exercises/practice/affine-cipher/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/affine-cipher/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/affine-cipher/test.scm b/exercises/practice/affine-cipher/test.scm index 870474f8..9e39e0bc 100644 --- a/exercises/practice/affine-cipher/test.scm +++ b/exercises/practice/affine-cipher/test.scm @@ -1,179 +1,47 @@ -(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 encode) - -(define decode) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "encode yes" equal? encode '((5 . 7) "yes") - "xbt")) - (lambda () - (test-success "encode no" equal? encode '((15 . 18) "no") - "fu")) - (lambda () - (test-success "encode OMG" equal? encode '((21 . 3) "OMG") - "lvz")) - (lambda () - (test-success "encode O M G" equal? encode - '((25 . 47) "O M G") "hjp")) - (lambda () - (test-success "encode mindblowingly" equal? encode - '((11 . 15) "mindblowingly") "rzcwa gnxzc dgt")) - (lambda () - (test-success "encode numbers" equal? encode - '((3 . 4) "Testing,1 2 3, testing.") - "jqgjc rw123 jqgjc rw")) - (lambda () - (test-success "encode deep thought" equal? encode - '((5 . 17) "Truth is fiction.") "iynia fdqfb ifje")) - (lambda () - (test-success "encode all the letters" equal? encode - '((17 . 33) "The quick brown fox jumps over the lazy dog.") - "swxtj npvyk lruol iejdc blaxk swxmh qzglf")) - (lambda () - (test-error - "encode with a not coprime to m" - encode - '(((a . 6) (b . 17)) "This is a test."))) - (lambda () - (test-success "decode exercism" equal? decode - '((3 . 7) "tytgn fjr") "exercism")) - (lambda () - (test-success "decode a sentence" equal? decode - '((19 . 16) "qdwju nqcro muwhn odqun oppmd aunwd o") - "anobstacleisoftenasteppingstone")) - (lambda () - (test-success "decode numbers" equal? decode - '((25 . 7) "odpoz ub123 odpoz ub") "testing123testing")) - (lambda () - (test-success "decode all the letters" equal? decode - '((17 . 33) "swxtj npvyk lruol iejdc blaxk swxmh qzglf") - "thequickbrownfoxjumpsoverthelazydog")) - (lambda () - (test-success "decode with no spaces in input" equal? decode - '((17 . 33) "swxtjnpvyklruoliejdcblaxkswxmhqzglf") - "thequickbrownfoxjumpsoverthelazydog")) - (lambda () - (test-success "decode with too many spaces" equal? decode - '((15 . 16) "vszzm cly yd cg qdp") - "jollygreengiant")) - (lambda () - (test-error - "decode with a not coprime to m" - decode - '(((a . 13) (b . 5)) "Test"))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "affine-cipher.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "affine-cipher.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "encode yes" equal? encode '((5 . 7) "yes") + "xbt") + (test-success "encode no" equal? encode '((15 . 18) "no") + "fu") + (test-success "encode OMG" equal? encode '((21 . 3) "OMG") + "lvz") + (test-success "encode O M G" equal? encode + '((25 . 47) "O M G") "hjp") + (test-success "encode mindblowingly" equal? encode + '((11 . 15) "mindblowingly") "rzcwa gnxzc dgt") + (test-success "encode numbers" equal? encode + '((3 . 4) "Testing,1 2 3, testing.") "jqgjc rw123 jqgjc rw") + (test-success "encode deep thought" equal? encode + '((5 . 17) "Truth is fiction.") "iynia fdqfb ifje") + (test-success "encode all the letters" equal? encode + '((17 . 33) "The quick brown fox jumps over the lazy dog.") + "swxtj npvyk lruol iejdc blaxk swxmh qzglf") + (test-error + "encode with a not coprime to m" + encode + '(((a . 6) (b . 17)) "This is a test.")) + (test-success "decode exercism" equal? decode + '((3 . 7) "tytgn fjr") "exercism") + (test-success "decode a sentence" equal? decode + '((19 . 16) "qdwju nqcro muwhn odqun oppmd aunwd o") + "anobstacleisoftenasteppingstone") + (test-success "decode numbers" equal? decode + '((25 . 7) "odpoz ub123 odpoz ub") "testing123testing") + (test-success "decode all the letters" equal? decode + '((17 . 33) "swxtj npvyk lruol iejdc blaxk swxmh qzglf") + "thequickbrownfoxjumpsoverthelazydog") + (test-success "decode with no spaces in input" equal? decode + '((17 . 33) "swxtjnpvyklruoliejdcblaxkswxmhqzglf") + "thequickbrownfoxjumpsoverthelazydog") + (test-success "decode with too many spaces" equal? decode + '((15 . 16) "vszzm cly yd cg qdp") + "jollygreengiant") + (test-error + "decode with a not coprime to m" + decode + '(((a . 13) (b . 5)) "Test")))) + +(run-with-cli "affine-cipher.scm" (list test-cases)) diff --git a/exercises/practice/anagram/.meta/config.json b/exercises/practice/anagram/.meta/config.json index 30524779..5a355bae 100644 --- a/exercises/practice/anagram/.meta/config.json +++ b/exercises/practice/anagram/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a word and a list of possible anagrams, select the correct sublist.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "anagram.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a word and a list of possible anagrams, select the correct sublist.", "source": "Inspired by the Extreme Startup game", "source_url": "https://github.com/rchatley/extreme_startup" } diff --git a/exercises/practice/anagram/test-util.ss b/exercises/practice/anagram/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/anagram/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/anagram/test.scm b/exercises/practice/anagram/test.scm index a8416c8b..8f24fff7 100644 --- a/exercises/practice/anagram/test.scm +++ b/exercises/practice/anagram/test.scm @@ -1,204 +1,76 @@ -(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 anagram) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no matches" - (lambda (xs ys) - (equal? (list-sort stringstring 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 'actual)]))) diff --git a/exercises/practice/armstrong-numbers/test.scm b/exercises/practice/armstrong-numbers/test.scm index 5e3ea931..277a0d27 100644 --- a/exercises/practice/armstrong-numbers/test.scm +++ b/exercises/practice/armstrong-numbers/test.scm @@ -1,203 +1,60 @@ -(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 armstrong-number?) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success - "Zero is an Armstrong number" equal? - armstrong-number? '(0) #t)) - (lambda () - (test-success - "Single digit numbers are Armstrong numbers" equal? - armstrong-number? '(5) #t)) - (lambda () - (test-success - "There are no 2 digit Armstrong numbers" equal? - armstrong-number? '(10) #f)) - (lambda () - (test-success - "Three digit number that is an Armstrong number" equal? - armstrong-number? '(153) #t)) - (lambda () - (test-success - "Three digit number that is not an Armstrong number" equal? - armstrong-number? '(100) #f)) - (lambda () - (test-success - "Four digit number that is an Armstrong number" equal? - armstrong-number? '(9474) #t)) - (lambda () - (test-success - "Four digit number that is not an Armstrong number" equal? - armstrong-number? '(9475) #f)) - (lambda () - (test-success - "Seven digit number that is an Armstrong number" equal? - armstrong-number? '(9926315) #t)) - (lambda () - (test-success - "Seven digit number that is not an Armstrong number" equal? - armstrong-number? '(9926314) #f)) - (lambda () - (test-success - "The 25th Armstrong number" equal? - armstrong-number? '(24678050) #t)) - (lambda () - (test-success - "Eight digit number that is not an Armstrong number" equal? - armstrong-number? '(30852815) #f)) - (lambda () - (test-success - "The 28th Armstrong number" equal? - armstrong-number? '(146511208) #t)) - (lambda () - (test-success - "Nine digit number that is not an Armstrong number" equal? - armstrong-number? '(927427554) #f)) - (lambda () - (test-success - "The 32nd Armstrong number" equal? - armstrong-number? '(4679307774) #t)) - (lambda () - (test-success - "Ten digit number that is not an Armstrong number" equal? - armstrong-number? '(8320172640) #f)) - (lambda () - (test-success - "The 34th Armstrong number" equal? - armstrong-number? '(32164049651) #t)) - (lambda () - (test-success - "Eleven digit number that is not an Armstrong number" equal? - armstrong-number? '(13930642218) #f)) - (lambda () - (test-success - "The 66th Armstrong number" equal? - armstrong-number? '(4422095118095899619457938) #t)) - (lambda () - (test-success - "The 77th Armstrong number" equal? - armstrong-number? '(1927890457142960697580636236639) #t)) - (lambda () - (test-success - "The 88th Armstrong number" equal? - armstrong-number? '(115132219018763992565095597973971522401) #t)) - (lambda () - (test-success - "Thirty-nine digit number that is not an Armstrong number" equal? - armstrong-number? '(7744959048678381442547644364350528967165) #f)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "armstrong-numbers.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "armstrong-numbers.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "Zero is an Armstrong number" equal? + armstrong-number? '(0) #t) + (test-success "Single digit numbers are Armstrong numbers" + equal? armstrong-number? '(5) #t) + (test-success "There are no 2 digit Armstrong numbers" + equal? armstrong-number? '(10) #f) + (test-success + "Three digit number that is an Armstrong number" equal? + armstrong-number? '(153) #t) + (test-success + "Three digit number that is not an Armstrong number" equal? + armstrong-number? '(100) #f) + (test-success + "Four digit number that is an Armstrong number" equal? + armstrong-number? '(9474) #t) + (test-success + "Four digit number that is not an Armstrong number" equal? + armstrong-number? '(9475) #f) + (test-success + "Seven digit number that is an Armstrong number" equal? + armstrong-number? '(9926315) #t) + (test-success + "Seven digit number that is not an Armstrong number" equal? + armstrong-number? '(9926314) #f) + (test-success "The 25th Armstrong number" equal? + armstrong-number? '(24678050) #t) + (test-success + "Eight digit number that is not an Armstrong number" equal? + armstrong-number? '(30852815) #f) + (test-success "The 28th Armstrong number" equal? + armstrong-number? '(146511208) #t) + (test-success + "Nine digit number that is not an Armstrong number" equal? + armstrong-number? '(927427554) #f) + (test-success "The 32nd Armstrong number" equal? + armstrong-number? '(4679307774) #t) + (test-success + "Ten digit number that is not an Armstrong number" equal? + armstrong-number? '(8320172640) #f) + (test-success "The 34th Armstrong number" equal? + armstrong-number? '(32164049651) #t) + (test-success + "Eleven digit number that is not an Armstrong number" equal? + armstrong-number? '(13930642218) #f) + (test-success "The 66th Armstrong number" equal? + armstrong-number? '(4422095118095899619457938) #t) + (test-success "The 77th Armstrong number" equal? + armstrong-number? '(1927890457142960697580636236639) #t) + (test-success "The 88th Armstrong number" equal? + armstrong-number? '(115132219018763992565095597973971522401) + #t) + (test-success "Thirty-nine digit number that is not an Armstrong number" + equal? armstrong-number? + '(7744959048678381442547644364350528967165) #f))) + +(run-with-cli "armstrong-numbers.scm" (list test-cases)) diff --git a/exercises/practice/atbash-cipher/.meta/config.json b/exercises/practice/atbash-cipher/.meta/config.json index 63a0cf07..13e6f680 100644 --- a/exercises/practice/atbash-cipher/.meta/config.json +++ b/exercises/practice/atbash-cipher/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Create an implementation of the atbash cipher, an ancient encryption system created in the Middle East.", "authors": [ "mattwellss" ], @@ -13,12 +12,14 @@ "atbash-cipher.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Create an implementation of the atbash cipher, an ancient encryption system created in the Middle East.", "source": "Wikipedia", "source_url": "http://en.wikipedia.org/wiki/Atbash" } diff --git a/exercises/practice/atbash-cipher/test-util.ss b/exercises/practice/atbash-cipher/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/atbash-cipher/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/atbash-cipher/test.scm b/exercises/practice/atbash-cipher/test.scm index 5d690f2e..7b9fcfb1 100644 --- a/exercises/practice/atbash-cipher/test.scm +++ b/exercises/practice/atbash-cipher/test.scm @@ -1,164 +1,34 @@ -(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 encode) - -(define decode) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "encode yes" equal? encode '("yes") "bvh")) - (lambda () - (test-success "encode no" equal? encode '("no") "ml")) - (lambda () - (test-success "encode OMG" equal? encode '("OMG") "lnt")) - (lambda () - (test-success "encode spaces" equal? encode '("O M G") - "lnt")) - (lambda () - (test-success "encode mindblowingly" equal? encode - '("mindblowingly") "nrmwy oldrm tob")) - (lambda () - (test-success "encode numbers" equal? encode - '("Testing,1 2 3, testing.") "gvhgr mt123 gvhgr mt")) - (lambda () - (test-success "encode deep thought" equal? encode - '("Truth is fiction.") "gifgs rhurx grlm")) - (lambda () - (test-success "encode all the letters" equal? encode - '("The quick brown fox jumps over the lazy dog.") - "gsvjf rxpyi ldmul cqfnk hlevi gsvoz abwlt")) - (lambda () - (test-success "decode exercism" equal? decode '("vcvix rhn") - "exercism")) - (lambda () - (test-success "decode a sentence" equal? decode - '("zmlyh gzxov rhlug vmzhg vkkrm thglm v") - "anobstacleisoftenasteppingstone")) - (lambda () - (test-success "decode numbers" equal? decode - '("gvhgr mt123 gvhgr mt") "testing123testing")) - (lambda () - (test-success "decode all the letters" equal? decode - '("gsvjf rxpyi ldmul cqfnk hlevi gsvoz abwlt") - "thequickbrownfoxjumpsoverthelazydog")) - (lambda () - (test-success "decode with too many spaces" equal? decode - '("vc vix r hn") "exercism")) - (lambda () - (test-success "decode with no spaces" equal? decode - '("zmlyhgzxovrhlugvmzhgvkkrmthglmv") - "anobstacleisoftenasteppingstone")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "atbash-cipher.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "atbash-cipher.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "encode yes" equal? encode '("yes") "bvh") (test-success "encode no" equal? encode '("no") "ml") + (test-success "encode OMG" equal? encode '("OMG") "lnt") + (test-success "encode spaces" equal? encode '("O M G") + "lnt") + (test-success "encode mindblowingly" equal? encode + '("mindblowingly") "nrmwy oldrm tob") + (test-success "encode numbers" equal? encode + '("Testing,1 2 3, testing.") "gvhgr mt123 gvhgr mt") + (test-success "encode deep thought" equal? encode + '("Truth is fiction.") "gifgs rhurx grlm") + (test-success "encode all the letters" equal? encode + '("The quick brown fox jumps over the lazy dog.") + "gsvjf rxpyi ldmul cqfnk hlevi gsvoz abwlt") + (test-success "decode exercism" equal? decode '("vcvix rhn") + "exercism") + (test-success "decode a sentence" equal? decode + '("zmlyh gzxov rhlug vmzhg vkkrm thglm v") + "anobstacleisoftenasteppingstone") + (test-success "decode numbers" equal? decode + '("gvhgr mt123 gvhgr mt") "testing123testing") + (test-success "decode all the letters" equal? decode + '("gsvjf rxpyi ldmul cqfnk hlevi gsvoz abwlt") + "thequickbrownfoxjumpsoverthelazydog") + (test-success "decode with too many spaces" equal? decode + '("vc vix r hn") "exercism") + (test-success "decode with no spaces" equal? decode + '("zmlyhgzxovrhlugvmzhgvkkrmthglmv") + "anobstacleisoftenasteppingstone"))) + +(run-with-cli "atbash-cipher.scm" (list test-cases)) diff --git a/exercises/practice/binary-search/.meta/config.json b/exercises/practice/binary-search/.meta/config.json index 2fd2c75b..e6ee8451 100644 --- a/exercises/practice/binary-search/.meta/config.json +++ b/exercises/practice/binary-search/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Implement a binary search algorithm.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "binary-search.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Implement a binary search algorithm.", "source": "Wikipedia", "source_url": "http://en.wikipedia.org/wiki/Binary_search_algorithm" } diff --git a/exercises/practice/binary-search/test-util.ss b/exercises/practice/binary-search/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/binary-search/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/binary-search/test.scm b/exercises/practice/binary-search/test.scm index 575813c0..25d51770 100644 --- a/exercises/practice/binary-search/test.scm +++ b/exercises/practice/binary-search/test.scm @@ -1,156 +1,31 @@ -(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 binary-search) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "finds a value in an array with one element" - equal? binary-search '(#(6) 6) 0)) - (lambda () - (test-success "finds a value in the middle of an array" - equal? binary-search '(#(1 3 4 6 8 9 11) 6) 3)) - (lambda () - (test-success "finds a value at the beginning of an array" - equal? binary-search '(#(1 3 4 6 8 9 11) 1) 0)) - (lambda () - (test-success "finds a value at the end of an array" equal? - binary-search '(#(1 3 4 6 8 9 11) 11) 6)) - (lambda () - (test-success "finds a value in an array of odd length" equal? - binary-search - '(#(1 3 5 8 13 21 34 55 89 144 233 377 634) 144) 9)) - (lambda () - (test-success "finds a value in an array of even length" equal? - binary-search '(#(1 3 5 8 13 21 34 55 89 144 233 377) 21) - 5)) - (lambda () - (test-success "identifies that a value is not included in the array" - equal? binary-search '(#(1 3 4 6 8 9 11) 7) 'not-found)) - (lambda () - (test-success - "a value smaller than the array's smallest value is not found" - equal? binary-search '(#(1 3 4 6 8 9 11) 0) 'not-found)) - (lambda () - (test-success - "a value larger than the array's largest value is not found" - equal? binary-search '(#(1 3 4 6 8 9 11) 13) 'not-found)) - (lambda () - (test-success "nothing is found in an empty array" equal? - binary-search '(#() 1) 'not-found)) - (lambda () - (test-success "nothing is found when the left and right bounds cross" - equal? binary-search '(#(1 2) 0) 'not-found)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "binary-search.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "binary-search.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "finds a value in an array with one element" + equal? binary-search '(#(6) 6) 0) + (test-success "finds a value in the middle of an array" + equal? binary-search '(#(1 3 4 6 8 9 11) 6) 3) + (test-success "finds a value at the beginning of an array" + equal? binary-search '(#(1 3 4 6 8 9 11) 1) 0) + (test-success "finds a value at the end of an array" equal? + binary-search '(#(1 3 4 6 8 9 11) 11) 6) + (test-success "finds a value in an array of odd length" equal? + binary-search + '(#(1 3 5 8 13 21 34 55 89 144 233 377 634) 144) 9) + (test-success "finds a value in an array of even length" equal? + binary-search '(#(1 3 5 8 13 21 34 55 89 144 233 377) 21) 5) + (test-success "identifies that a value is not included in the array" + equal? binary-search '(#(1 3 4 6 8 9 11) 7) 'not-found) + (test-success + "a value smaller than the array's smallest value is not found" + equal? binary-search '(#(1 3 4 6 8 9 11) 0) 'not-found) + (test-success + "a value larger than the array's largest value is not found" + equal? binary-search '(#(1 3 4 6 8 9 11) 13) 'not-found) + (test-success "nothing is found in an empty array" equal? + binary-search '(#() 1) 'not-found) + (test-success "nothing is found when the left and right bounds cross" + equal? binary-search '(#(1 2) 0) 'not-found))) + +(run-with-cli "binary-search.scm" (list test-cases)) diff --git a/exercises/practice/bob/.meta/config.json b/exercises/practice/bob/.meta/config.json index 1f7decbd..f16c8f1e 100644 --- a/exercises/practice/bob/.meta/config.json +++ b/exercises/practice/bob/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Bob is a lackadaisical teenager. In conversation, his responses are very limited.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "bob.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Bob is a lackadaisical teenager. In conversation, his responses are very limited.", "source": "Inspired by the 'Deaf Grandma' exercise in Chris Pine's Learn to Program tutorial.", "source_url": "http://pine.fm/LearnToProgram/?Chapter=06" } diff --git a/exercises/practice/bob/test-util.ss b/exercises/practice/bob/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/bob/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/bob/test.scm b/exercises/practice/bob/test.scm index c8a78c32..c10502e2 100644 --- a/exercises/practice/bob/test.scm +++ b/exercises/practice/bob/test.scm @@ -1,196 +1,60 @@ -(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 response-for) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "stating something" equal? response-for - '("Tom-ay-to, tom-aaaah-to.") "Whatever.")) - (lambda () - (test-success "shouting" equal? response-for '("WATCH OUT!") - "Whoa, chill out!")) - (lambda () - (test-success "shouting gibberish" equal? response-for - '("FCECDFCAAB") "Whoa, chill out!")) - (lambda () - (test-success "asking a question" equal? response-for - '("Does this cryogenic chamber make me look fat?") "Sure.")) - (lambda () - (test-success "asking a numeric question" equal? - response-for '("You are, what, like 15?") "Sure.")) - (lambda () - (test-success "asking gibberish" equal? response-for - '("fffbbcbeab?") "Sure.")) - (lambda () - (test-success "talking forcefully" equal? response-for - '("Hi there!") "Whatever.")) - (lambda () - (test-success "using acronyms in regular speech" equal? response-for - '("It's OK if you don't want to go work for NASA.") - "Whatever.")) - (lambda () - (test-success "forceful question" equal? response-for - '("WHAT'S GOING ON?") "Calm down, I know what I'm doing!")) - (lambda () - (test-success "shouting numbers" equal? response-for - '("1, 2, 3 GO!") "Whoa, chill out!")) - (lambda () - (test-success "no letters" equal? response-for '("1, 2, 3") - "Whatever.")) - (lambda () - (test-success "question with no letters" equal? response-for - '("4?") "Sure.")) - (lambda () - (test-success "shouting with special characters" equal? response-for - '("ZOMG THE %^*@#$(*^ ZOMBIES ARE COMING!!11!!1!") - "Whoa, chill out!")) - (lambda () - (test-success "shouting with no exclamation mark" equal? - response-for '("I HATE THE DENTIST") "Whoa, chill out!")) - (lambda () - (test-success "statement containing question mark" equal? response-for - '("Ending with ? means a question.") "Whatever.")) - (lambda () - (test-success "non-letters with question" equal? - response-for '(":) ?") "Sure.")) - (lambda () - (test-success "prattling on" equal? response-for - '("Wait! Hang on. Are you going to be OK?") "Sure.")) - (lambda () - (test-success "silence" equal? response-for '("") - "Fine. Be that way!")) - (lambda () - (test-success "prolonged silence" equal? response-for - '(" ") "Fine. Be that way!")) - (lambda () - (test-success "alternate silence" equal? response-for - '("\t\t\t\t\t\t\t\t\t\t") "Fine. Be that way!")) - (lambda () - (test-success "multiple line question" equal? response-for - '("\nDoes this cryogenic chamber make me look fat?\nNo.") - "Whatever.")) - (lambda () - (test-success "starting with whitespace" equal? response-for - '(" hmmmmmmm...") "Whatever.")) - (lambda () - (test-success "ending with whitespace" equal? response-for - '("Okay if like my spacebar quite a bit? ") "Sure.")) - (lambda () - (test-success "other whitespace" equal? response-for - '("\n\r \t") "Fine. Be that way!")) - (lambda () - (test-success "non-question ending with whitespace" equal? response-for - '("This is a statement ending with whitespace ") - "Whatever.")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) (load "bob.scm") (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "bob.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "stating something" equal? response-for + '("Tom-ay-to, tom-aaaah-to.") "Whatever.") + (test-success "shouting" equal? response-for '("WATCH OUT!") + "Whoa, chill out!") + (test-success "shouting gibberish" equal? response-for + '("FCECDFCAAB") "Whoa, chill out!") + (test-success "asking a question" equal? response-for + '("Does this cryogenic chamber make me look fat?") "Sure.") + (test-success "asking a numeric question" equal? + response-for '("You are, what, like 15?") "Sure.") + (test-success "asking gibberish" equal? response-for + '("fffbbcbeab?") "Sure.") + (test-success "talking forcefully" equal? response-for + '("Hi there!") "Whatever.") + (test-success "using acronyms in regular speech" equal? response-for + '("It's OK if you don't want to go work for NASA.") + "Whatever.") + (test-success "forceful question" equal? response-for + '("WHAT'S GOING ON?") "Calm down, I know what I'm doing!") + (test-success "shouting numbers" equal? response-for + '("1, 2, 3 GO!") "Whoa, chill out!") + (test-success "no letters" equal? response-for '("1, 2, 3") + "Whatever.") + (test-success "question with no letters" equal? response-for + '("4?") "Sure.") + (test-success "shouting with special characters" equal? response-for + '("ZOMG THE %^*@#$(*^ ZOMBIES ARE COMING!!11!!1!") + "Whoa, chill out!") + (test-success "shouting with no exclamation mark" equal? + response-for '("I HATE THE DENTIST") "Whoa, chill out!") + (test-success "statement containing question mark" equal? response-for + '("Ending with ? means a question.") "Whatever.") + (test-success "non-letters with question" equal? + response-for '(":) ?") "Sure.") + (test-success "prattling on" equal? response-for + '("Wait! Hang on. Are you going to be OK?") "Sure.") + (test-success "silence" equal? response-for '("") + "Fine. Be that way!") + (test-success "prolonged silence" equal? response-for + '(" ") "Fine. Be that way!") + (test-success "alternate silence" equal? response-for + '("\t\t\t\t\t\t\t\t\t\t") "Fine. Be that way!") + (test-success "multiple line question" equal? response-for + '("\nDoes this cryogenic chamber make me look fat?\nNo.") + "Whatever.") + (test-success "starting with whitespace" equal? response-for + '(" hmmmmmmm...") "Whatever.") + (test-success "ending with whitespace" equal? response-for + '("Okay if like my spacebar quite a bit? ") "Sure.") + (test-success "other whitespace" equal? response-for + '("\n\r \t") "Fine. Be that way!") + (test-success "non-question ending with whitespace" equal? response-for + '("This is a statement ending with whitespace ") + "Whatever."))) + +(run-with-cli "bob.scm" (list test-cases)) diff --git a/exercises/practice/change/.meta/config.json b/exercises/practice/change/.meta/config.json index 1bfc2ffe..a0f6ff0a 100644 --- a/exercises/practice/change/.meta/config.json +++ b/exercises/practice/change/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Correctly determine change to be given using the least number of coins", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "change.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Correctly determine change to be given using the least number of coins", "source": "Software Craftsmanship - Coin Change Kata", "source_url": "https://web.archive.org/web/20130115115225/http://craftsmanship.sv.cmu.edu:80/exercises/coin-change-kata" } diff --git a/exercises/practice/change/test-util.ss b/exercises/practice/change/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/change/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/change/test.scm b/exercises/practice/change/test.scm index d6ccadd5..622ecc60 100644 --- a/exercises/practice/change/test.scm +++ b/exercises/practice/change/test.scm @@ -1,175 +1,51 @@ -(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 change) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "single coin change" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(25 (1 5 10 25 100)) '(25))) - (lambda () - (test-success "multiple coin change" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(15 (1 5 10 25 100)) '(5 10))) - (lambda () - (test-success "change with Lilliputian Coins" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(23 (1 4 15 20 50)) '(4 4 15))) - (lambda () - (test-success "change with Lower Elbonia Coins" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(63 (1 5 10 21 25)) '(21 21 21))) - (lambda () - (test-success "large target values" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(999 (1 2 5 10 20 50 100)) - '(2 2 5 20 20 50 100 100 100 100 100 100 100 100 100))) - (lambda () - (test-success "possible change without unit coins available" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(21 (2 5 10 20 50)) '(2 2 2 5 10))) - (lambda () - (test-success "another possible change without unit coins available" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(27 (4 5)) '(4 4 4 5 5 5))) - (lambda () - (test-success "no coins make 0 change" - (lambda (out expected) - (equal? (list-sort < out) (list-sort < expected))) - change '(0 (1 5 10 21 25)) '())) - (lambda () - (test-error - "error testing for change smaller than the smallest of coins" - change - '(3 (5 10)))) - (lambda () - (test-error - "error if no combination can add up to target" - change - '(94 (5 10)))) - (lambda () - (test-error - "cannot find negative change values" - change - '(-5 (1 2 5)))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "change.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "change.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "single coin change" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(25 (1 5 10 25 100)) '(25)) + (test-success "multiple coin change" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(15 (1 5 10 25 100)) '(5 10)) + (test-success "change with Lilliputian Coins" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(23 (1 4 15 20 50)) '(4 4 15)) + (test-success "change with Lower Elbonia Coins" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(63 (1 5 10 21 25)) '(21 21 21)) + (test-success "large target values" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(999 (1 2 5 10 20 50 100)) + '(2 2 5 20 20 50 100 100 100 100 100 100 100 100 100)) + (test-success "possible change without unit coins available" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(21 (2 5 10 20 50)) '(2 2 2 5 10)) + (test-success "another possible change without unit coins available" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(27 (4 5)) '(4 4 4 5 5 5)) + (test-success "no coins make 0 change" + (lambda (out expected) + (equal? (list-sort < out) (list-sort < expected))) + change '(0 (1 5 10 21 25)) '()) + (test-error + "error testing for change smaller than the smallest of coins" + change + '(3 (5 10))) + (test-error + "error if no combination can add up to target" + change + '(94 (5 10))) + (test-error + "cannot find negative change values" + change + '(-5 (1 2 5))))) + +(run-with-cli "change.scm" (list test-cases)) diff --git a/exercises/practice/collatz-conjecture/.meta/config.json b/exercises/practice/collatz-conjecture/.meta/config.json index 749b611a..3dea026c 100644 --- a/exercises/practice/collatz-conjecture/.meta/config.json +++ b/exercises/practice/collatz-conjecture/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Calculate the number of steps to reach 1 using the Collatz conjecture", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "collatz-conjecture.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Calculate the number of steps to reach 1 using the Collatz conjecture", "source": "An unsolved problem in mathematics named after mathematician Lothar Collatz", "source_url": "https://en.wikipedia.org/wiki/3x_%2B_1_problem" } diff --git a/exercises/practice/collatz-conjecture/test-util.ss b/exercises/practice/collatz-conjecture/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/collatz-conjecture/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/collatz-conjecture/test.scm b/exercises/practice/collatz-conjecture/test.scm index aa24bf0a..db09df95 100644 --- a/exercises/practice/collatz-conjecture/test.scm +++ b/exercises/practice/collatz-conjecture/test.scm @@ -1,128 +1,11 @@ -(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)) + `((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))) -(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)])) +(run-with-cli "collatz-conjecture.scm" (list test-cases)) diff --git a/exercises/practice/difference-of-squares/.meta/config.json b/exercises/practice/difference-of-squares/.meta/config.json index 512a57b2..ea4e7f62 100644 --- a/exercises/practice/difference-of-squares/.meta/config.json +++ b/exercises/practice/difference-of-squares/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Find the difference between the square of the sum and the sum of the squares of the first N natural numbers.", "authors": [ "canweriotnow" ], @@ -16,12 +15,14 @@ "difference-of-squares.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Find the difference between the square of the sum and the sum of the squares of the first N natural numbers.", "source": "Problem 6 at Project Euler", "source_url": "http://projecteuler.net/problem=6" } diff --git a/exercises/practice/difference-of-squares/test-util.ss b/exercises/practice/difference-of-squares/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/difference-of-squares/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/difference-of-squares/test.scm b/exercises/practice/difference-of-squares/test.scm index 9e62fc1a..f99b159e 100644 --- a/exercises/practice/difference-of-squares/test.scm +++ b/exercises/practice/difference-of-squares/test.scm @@ -1,146 +1,19 @@ -(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 sum-of-squares) - -(define difference-of-squares) - -(define square-of-sum) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "square of sum 1" = square-of-sum '(1) 1)) - (lambda () - (test-success "square of sum 5" = square-of-sum '(5) 225)) - (lambda () - (test-success "square of sum 100" = square-of-sum '(100) - 25502500)) - (lambda () - (test-success "sum of squares 1" = sum-of-squares '(1) 1)) - (lambda () - (test-success "sum of squares 5" = sum-of-squares '(5) 55)) - (lambda () - (test-success "sum of squares 100" = sum-of-squares '(100) - 338350)) - (lambda () - (test-success "difference of squares 1" = - difference-of-squares '(1) 0)) - (lambda () - (test-success "difference of squares 5" = - difference-of-squares '(5) 170)) - (lambda () - (test-success "difference of squares 100" = - difference-of-squares '(100) 25164150)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "difference-of-squares.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "difference-of-squares.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "square of sum 1" = square-of-sum '(1) 1) (test-success "square of sum 5" = square-of-sum '(5) 225) + (test-success "square of sum 100" = square-of-sum '(100) + 25502500) + (test-success "sum of squares 1" = sum-of-squares '(1) 1) + (test-success "sum of squares 5" = sum-of-squares '(5) 55) + (test-success "sum of squares 100" = sum-of-squares '(100) + 338350) + (test-success "difference of squares 1" = + difference-of-squares '(1) 0) + (test-success "difference of squares 5" = + difference-of-squares '(5) 170) + (test-success "difference of squares 100" = + difference-of-squares '(100) 25164150))) + +(run-with-cli "difference-of-squares.scm" (list test-cases)) diff --git a/exercises/practice/forth/.meta/config.json b/exercises/practice/forth/.meta/config.json index 94bfea56..1a388420 100644 --- a/exercises/practice/forth/.meta/config.json +++ b/exercises/practice/forth/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Implement an evaluator for a very simple subset of Forth", "authors": [ "jitwit" ], @@ -8,10 +7,12 @@ "forth.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] - } + }, + "blurb": "Implement an evaluator for a very simple subset of Forth" } diff --git a/exercises/practice/forth/test-util.ss b/exercises/practice/forth/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/forth/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/forth/test.scm b/exercises/practice/forth/test.scm index 60e61c86..87896024 100644 --- a/exercises/practice/forth/test.scm +++ b/exercises/practice/forth/test.scm @@ -1,295 +1,132 @@ -(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 forth) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "numbers just get pushed onto the stack" - equal? forth '(("1 2 3 4 5")) '(5 4 3 2 1))) - (lambda () - (test-success "can add two numbers" equal? forth - '(("1 2 +")) '(3))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("+")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 +")))) - (lambda () - (test-success "can subtract two numbers" equal? forth - '(("3 4 -")) '(-1))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("-")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 -")))) - (lambda () - (test-success "can multiply two numbers" equal? forth - '(("2 4 *")) '(8))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("*")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 *")))) - (lambda () - (test-success "can divide two numbers" equal? forth - '(("12 3 /")) '(4))) - (lambda () - (test-success "performs integer division" equal? forth - '(("8 3 /")) '(2))) - (lambda () - (test-error - "errors if dividing by zero" - forth - '(("4 0 /")))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("/")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 /")))) - (lambda () - (test-success "addition and subtraction" equal? forth - '(("1 2 + 4 -")) '(-1))) - (lambda () - (test-success "multiplication and division" equal? forth - '(("2 4 * 3 /")) '(2))) - (lambda () - (test-success "copies a value on the stack" equal? forth - '(("1 dup")) '(1 1))) - (lambda () - (test-success "copies the top value on the stack" equal? - forth '(("1 2 dup")) '(2 2 1))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("dup")))) - (lambda () - (test-success - "removes the top value on the stack if it is the only one" - equal? forth '(("1 drop")) '())) - (lambda () - (test-success - "removes the top value on the stack if it is not the only one" - equal? forth '(("1 2 drop")) '(1))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("drop")))) - (lambda () - (test-success - "swaps the top two values on the stack if they are the only ones" - equal? forth '(("1 2 swap")) '(1 2))) - (lambda () - (test-success - "swaps the top two values on the stack if they are not the only ones" - equal? forth '(("1 2 3 swap")) '(2 3 1))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("swap")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 swap")))) - (lambda () - (test-success - "copies the second element if there are only two" equal? - forth '(("1 2 over")) '(1 2 1))) - (lambda () - (test-success - "copies the second element if there are more than two" - equal? forth '(("1 2 3 over")) '(2 3 2 1))) - (lambda () - (test-error - "errors if there is nothing on the stack" - forth - '(("over")))) - (lambda () - (test-error - "errors if there is only one value on the stack" - forth - '(("1 over")))) - (lambda () - (test-success "can consist of built-in words" equal? forth - '((": dup-twice dup dup ;" "1 dup-twice")) '(1 1 1))) - (lambda () - (test-success "execute in the right order" equal? forth - '((": countup 1 2 3 ;" "countup")) '(3 2 1))) - (lambda () - (test-success "can override other user-defined words" equal? forth - '((": foo dup ;" ": foo dup dup ;" "1 foo")) '(1 1 1))) - (lambda () - (test-success "can override built-in words" equal? forth - '((": swap dup ;" "1 swap")) '(1 1))) - (lambda () - (test-success "can override built-in operators" equal? forth - '((": + * ;" "3 4 +")) '(12))) - (lambda () - (test-success "can use different words with the same name" equal? forth - '((": foo 5 ;" ": bar foo ;" ": foo 6 ;" "bar foo")) - '(6 5))) - (lambda () - (test-success "can define word that uses word with the same name" equal? - forth '((": foo 10 ;" ": foo foo 1 + ;" "foo")) '(11))) - (lambda () - (test-error "cannot redefine numbers" forth '((": 1 2 ;")))) - (lambda () - (test-error - "errors if executing a non-existent word" - forth - '(("foo")))) - (lambda () - (test-success "DUP is case-insensitive" equal? forth - '(("1 DUP Dup dup")) '(1 1 1 1))) - (lambda () - (test-success "DROP is case-insensitive" equal? forth - '(("1 2 3 4 DROP Drop drop")) '(1))) - (lambda () - (test-success "SWAP is case-insensitive" equal? forth - '(("1 2 SWAP 3 Swap 4 swap")) '(1 4 3 2))) - (lambda () - (test-success "OVER is case-insensitive" equal? forth - '(("1 2 OVER Over over")) '(1 2 1 2 1))) - (lambda () - (test-success "user-defined words are case-insensitive" equal? forth - '((": foo dup ;" "1 FOO Foo foo")) '(1 1 1 1))) - (lambda () - (test-success "definitions are case-insensitive" equal? - forth '((": SWAP DUP Dup dup ;" "1 swap")) '(1 1 1 1))))) - -(define (test . query) - (apply run-test-suite test-cases query)) + `((test-success "numbers just get pushed onto the stack" + equal? forth '(("1 2 3 4 5")) '(5 4 3 2 1)) + (test-success "can add two numbers" equal? forth + '(("1 2 +")) '(3)) + (test-error + "errors if there is nothing on the stack" + forth + '(("+"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 +"))) + (test-success "can subtract two numbers" equal? forth + '(("3 4 -")) '(-1)) + (test-error + "errors if there is nothing on the stack" + forth + '(("-"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 -"))) + (test-success "can multiply two numbers" equal? forth + '(("2 4 *")) '(8)) + (test-error + "errors if there is nothing on the stack" + forth + '(("*"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 *"))) + (test-success "can divide two numbers" equal? forth + '(("12 3 /")) '(4)) + (test-success "performs integer division" equal? forth + '(("8 3 /")) '(2)) + (test-error "errors if dividing by zero" forth '(("4 0 /"))) + (test-error + "errors if there is nothing on the stack" + forth + '(("/"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 /"))) + (test-success "addition and subtraction" equal? forth + '(("1 2 + 4 -")) '(-1)) + (test-success "multiplication and division" equal? forth + '(("2 4 * 3 /")) '(2)) + (test-success "copies a value on the stack" equal? forth + '(("1 dup")) '(1 1)) + (test-success "copies the top value on the stack" equal? + forth '(("1 2 dup")) '(2 2 1)) + (test-error + "errors if there is nothing on the stack" + forth + '(("dup"))) + (test-success + "removes the top value on the stack if it is the only one" + equal? forth '(("1 drop")) '()) + (test-success + "removes the top value on the stack if it is not the only one" + equal? forth '(("1 2 drop")) '(1)) + (test-error + "errors if there is nothing on the stack" + forth + '(("drop"))) + (test-success + "swaps the top two values on the stack if they are the only ones" + equal? forth '(("1 2 swap")) '(1 2)) + (test-success + "swaps the top two values on the stack if they are not the only ones" + equal? forth '(("1 2 3 swap")) '(2 3 1)) + (test-error + "errors if there is nothing on the stack" + forth + '(("swap"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 swap"))) + (test-success + "copies the second element if there are only two" equal? + forth '(("1 2 over")) '(1 2 1)) + (test-success + "copies the second element if there are more than two" + equal? forth '(("1 2 3 over")) '(2 3 2 1)) + (test-error + "errors if there is nothing on the stack" + forth + '(("over"))) + (test-error + "errors if there is only one value on the stack" + forth + '(("1 over"))) + (test-success "can consist of built-in words" equal? forth + '((": dup-twice dup dup ;" "1 dup-twice")) '(1 1 1)) + (test-success "execute in the right order" equal? forth + '((": countup 1 2 3 ;" "countup")) '(3 2 1)) + (test-success "can override other user-defined words" equal? forth + '((": foo dup ;" ": foo dup dup ;" "1 foo")) '(1 1 1)) + (test-success "can override built-in words" equal? forth + '((": swap dup ;" "1 swap")) '(1 1)) + (test-success "can override built-in operators" equal? forth + '((": + * ;" "3 4 +")) '(12)) + (test-success "can use different words with the same name" equal? forth + '((": foo 5 ;" ": bar foo ;" ": foo 6 ;" "bar foo")) '(6 5)) + (test-success "can define word that uses word with the same name" equal? + forth '((": foo 10 ;" ": foo foo 1 + ;" "foo")) '(11)) + (test-error "cannot redefine numbers" forth '((": 1 2 ;"))) + (test-error + "errors if executing a non-existent word" + forth + '(("foo"))) + (test-success "DUP is case-insensitive" equal? forth + '(("1 DUP Dup dup")) '(1 1 1 1)) + (test-success "DROP is case-insensitive" equal? forth + '(("1 2 3 4 DROP Drop drop")) '(1)) + (test-success "SWAP is case-insensitive" equal? forth + '(("1 2 SWAP 3 Swap 4 swap")) '(1 4 3 2)) + (test-success "OVER is case-insensitive" equal? forth + '(("1 2 OVER Over over")) '(1 2 1 2 1)) + (test-success "user-defined words are case-insensitive" equal? forth + '((": foo dup ;" "1 FOO Foo foo")) '(1 1 1 1)) + (test-success "definitions are case-insensitive" equal? + forth '((": SWAP DUP Dup dup ;" "1 swap")) '(1 1 1 1)))) -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "forth.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "forth.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) +(run-with-cli "forth.scm" (list test-cases)) diff --git a/exercises/practice/grains/.meta/config.json b/exercises/practice/grains/.meta/config.json index 130f712e..72446b6b 100644 --- a/exercises/practice/grains/.meta/config.json +++ b/exercises/practice/grains/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Calculate the number of grains of wheat on a chessboard given that the number on each square doubles.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "grains.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Calculate the number of grains of wheat on a chessboard given that the number on each square doubles.", "source": "JavaRanch Cattle Drive, exercise 6", "source_url": "http://www.javaranch.com/grains.jsp" } diff --git a/exercises/practice/grains/test-util.ss b/exercises/practice/grains/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/grains/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/grains/test.scm b/exercises/practice/grains/test.scm index ade45d20..393465fd 100644 --- a/exercises/practice/grains/test.scm +++ b/exercises/practice/grains/test.scm @@ -1,146 +1,24 @@ -(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 square) - -(define total) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success - "returns the total number of grains on the board" equal? - total '() 18446744073709551615)) - (lambda () (test-success "1" equal? square '(1) 1)) - (lambda () (test-success "2" equal? square '(2) 2)) - (lambda () (test-success "3" equal? square '(3) 4)) - (lambda () (test-success "4" equal? square '(4) 8)) - (lambda () (test-success "16" equal? square '(16) 32768)) - (lambda () - (test-success "32" equal? square '(32) 2147483648)) - (lambda () - (test-success "64" equal? square '(64) 9223372036854775808)) - (lambda () - (test-error "square 0 raises an exception" square '(0))) - (lambda () - (test-error - "negative square raises an exception" - square - '(-1))) - (lambda () - (test-error - "square greater than 64 raises an exception" - square - '(65))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "grains.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "grains.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success + "returns the total number of grains on the board" equal? + total '() 18446744073709551615) (test-success "1" equal? square '(1) 1) + (test-success "2" equal? square '(2) 2) + (test-success "3" equal? square '(3) 4) + (test-success "4" equal? square '(4) 8) + (test-success "16" equal? square '(16) 32768) + (test-success "32" equal? square '(32) 2147483648) + (test-success "64" equal? square '(64) 9223372036854775808) + (test-error "square 0 raises an exception" square '(0)) + (test-error + "negative square raises an exception" + square + '(-1)) + (test-error + "square greater than 64 raises an exception" + square + '(65)))) + +(run-with-cli "grains.scm" (list test-cases)) diff --git a/exercises/practice/hamming/.meta/config.json b/exercises/practice/hamming/.meta/config.json index b5a41f2e..5b1d96b5 100644 --- a/exercises/practice/hamming/.meta/config.json +++ b/exercises/practice/hamming/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Calculate the Hamming difference between two DNA strands.", "authors": [ "PurityControl" ], @@ -15,12 +14,14 @@ "hamming.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Calculate the Hamming difference between two DNA strands.", "source": "The Calculating Point Mutations problem at Rosalind", "source_url": "http://rosalind.info/problems/hamm/" } diff --git a/exercises/practice/hamming/test-util.ss b/exercises/practice/hamming/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/hamming/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/hamming/test.scm b/exercises/practice/hamming/test.scm index 2004fc64..f9befd08 100644 --- a/exercises/practice/hamming/test.scm +++ b/exercises/practice/hamming/test.scm @@ -1,154 +1,32 @@ -(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 hamming-distance) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "empty strands" = hamming-distance '("" "") - 0)) - (lambda () - (test-success "single letter identical strands" = - hamming-distance '("A" "A") 0)) - (lambda () - (test-success "single letter different strands" = - hamming-distance '("G" "T") 1)) - (lambda () - (test-success "long identical strands" = hamming-distance - '("GGACTGAAATCTG" "GGACTGAAATCTG") 0)) - (lambda () - (test-success "long different strands" = hamming-distance - '("GGACGGATTCTG" "AGGACGGATTCT") 9)) - (lambda () - (test-error - "disallow first strand longer" - hamming-distance - '("AATG" "AAA"))) - (lambda () - (test-error - "disallow second strand longer" - hamming-distance - '("ATA" "AGTG"))) - (lambda () - (test-error - "disallow left empty strand" - hamming-distance - '("" "G"))) - (lambda () - (test-error - "disallow right empty strand" - hamming-distance - '("G" ""))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "hamming.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "hamming.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "empty strands" = hamming-distance '("" "") + 0) + (test-success "single letter identical strands" = + hamming-distance '("A" "A") 0) + (test-success "single letter different strands" = + hamming-distance '("G" "T") 1) + (test-success "long identical strands" = hamming-distance + '("GGACTGAAATCTG" "GGACTGAAATCTG") 0) + (test-success "long different strands" = hamming-distance + '("GGACGGATTCTG" "AGGACGGATTCT") 9) + (test-error + "disallow first strand longer" + hamming-distance + '("AATG" "AAA")) + (test-error + "disallow second strand longer" + hamming-distance + '("ATA" "AGTG")) + (test-error + "disallow left empty strand" + hamming-distance + '("" "G")) + (test-error + "disallow right empty strand" + hamming-distance + '("G" "")))) + +(run-with-cli "hamming.scm" (list test-cases)) diff --git a/exercises/practice/hello-world/.meta/config.json b/exercises/practice/hello-world/.meta/config.json index 679d7d3d..14ef0e91 100644 --- a/exercises/practice/hello-world/.meta/config.json +++ b/exercises/practice/hello-world/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "The classical introductory exercise. Just say \"Hello, World!\"", "authors": [ "canweriotnow" ], @@ -17,12 +16,14 @@ "hello-world.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "The classical introductory exercise. Just say \"Hello, World!\"", "source": "This is an exercise to introduce users to using Exercism", "source_url": "http://en.wikipedia.org/wiki/%22Hello,_world!%22_program" } diff --git a/exercises/practice/hello-world/test-util.ss b/exercises/practice/hello-world/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/hello-world/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/hello-world/test.scm b/exercises/practice/hello-world/test.scm index 7994e7eb..dfec49ee 100644 --- a/exercises/practice/hello-world/test.scm +++ b/exercises/practice/hello-world/test.scm @@ -1,122 +1,8 @@ -(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 hello-world) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "Say Hi!" equal? hello-world '() - "Hello, World!")))) - -(define (test . query) - (apply run-test-suite test-cases query)) + `((test-success "Say Hi!" equal? hello-world '() + "Hello, World!"))) -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "hello-world.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "hello-world.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) +(run-with-cli "hello-world.scm" (list test-cases)) diff --git a/exercises/practice/knapsack/.meta/config.json b/exercises/practice/knapsack/.meta/config.json index 1c5ce99f..b4c4d363 100644 --- a/exercises/practice/knapsack/.meta/config.json +++ b/exercises/practice/knapsack/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a knapsack that can only carry a certain weight, determine which items to put in the knapsack in order to maximize their combined value.", "authors": [ "jitwit" ], @@ -11,12 +10,14 @@ "knapsack.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a knapsack that can only carry a certain weight, determine which items to put in the knapsack in order to maximize their combined value.", "source": "Wikipedia", "source_url": "https://en.wikipedia.org/wiki/Knapsack_problem" } diff --git a/exercises/practice/knapsack/test-util.ss b/exercises/practice/knapsack/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/knapsack/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/knapsack/test.scm b/exercises/practice/knapsack/test.scm index a238633d..0411da44 100644 --- a/exercises/practice/knapsack/test.scm +++ b/exercises/practice/knapsack/test.scm @@ -1,167 +1,45 @@ -(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 knapsack) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no items" = knapsack '(100 () ()) 0)) - (lambda () - (test-success "one item, too heavy" = knapsack - '(10 (100) (1)) 0)) - (lambda () - (test-success "five items (cannot be greedy by weight)" = - knapsack '(10 (2 2 2 2 10) (5 5 5 5 21)) 21)) - (lambda () - (test-success "five items (cannot be greedy by value)" = - knapsack '(10 (2 2 2 2 10) (20 20 20 20 50)) 80)) - (lambda () - (test-success "example knapsack" = knapsack - '(10 (5 4 6 4) (10 40 30 50)) 90)) - (lambda () - (test-success "8 items" = knapsack - '(104 (25 35 45 5 25 3 2 2) (350 400 450 20 70 8 5 5)) 900)) - (lambda () - (test-success "15 items" = knapsack - '(750 (70 73 77 80 82 87 90 94 98 106 110 113 115 118 120) - (135 139 149 150 156 163 173 184 192 201 210 214 221 229 - 240)) - 1458)) - (lambda () - (test-success "example with 30 items" = knapsack - '(100000 - (90001 89751 10002 89501 10254 89251 10506 89001 10758 88751 - 11010 88501 11262 88251 11514 88001 11766 87751 12018 87501 - 12270 87251 12522 87001 12774 86751 13026 86501 13278 86251) - (90000 89750 10001 89500 10252 89250 10503 89000 10754 88750 - 11005 88500 11256 88250 11507 88000 11758 87750 12009 87500 - 12260 87250 12511 87000 12762 86750 13013 86500 13264 - 86250)) - 99798)) - (lambda () - (test-success "example with 50 items" = knapsack - '(341045 - (4912 99732 56554 1818 108372 6750 1484 3072 13532 12050 - 18440 10972 1940 122094 5558 10630 2112 6942 39888 71276 - 8466 5662 231302 4690 18324 3384 7278 5566 706 10992 27552 - 7548 934 32038 1062 184848 2604 37644 1832 10306 1126 34886 - 3526 1196 1338 992 1390 56804 56804 634) - (1906 41516 23527 559 45136 2625 492 1086 5516 4875 7570 4436 - 620 50897 2129 4265 706 2721 16494 29688 3383 2181 96601 - 1795 7512 1242 2889 2133 103 4446 11326 3024 217 13269 281 - 77174 952 15572 566 4103 313 14393 1313 348 419 246 445 - 23552 23552 67)) - 142156)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "knapsack.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "knapsack.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "no items" = knapsack '(100 () ()) 0) + (test-success "one item, too heavy" = knapsack + '(10 (100) (1)) 0) + (test-success "five items (cannot be greedy by weight)" = + knapsack '(10 (2 2 2 2 10) (5 5 5 5 21)) 21) + (test-success "five items (cannot be greedy by value)" = + knapsack '(10 (2 2 2 2 10) (20 20 20 20 50)) 80) + (test-success "example knapsack" = knapsack + '(10 (5 4 6 4) (10 40 30 50)) 90) + (test-success "8 items" = knapsack + '(104 (25 35 45 5 25 3 2 2) (350 400 450 20 70 8 5 5)) 900) + (test-success "15 items" = knapsack + '(750 (70 73 77 80 82 87 90 94 98 106 110 113 115 118 120) + (135 139 149 150 156 163 173 184 192 201 210 214 221 229 + 240)) + 1458) + (test-success "example with 30 items" = knapsack + '(100000 + (90001 89751 10002 89501 10254 89251 10506 89001 10758 88751 + 11010 88501 11262 88251 11514 88001 11766 87751 12018 87501 + 12270 87251 12522 87001 12774 86751 13026 86501 13278 86251) + (90000 89750 10001 89500 10252 89250 10503 89000 10754 88750 + 11005 88500 11256 88250 11507 88000 11758 87750 12009 87500 + 12260 87250 12511 87000 12762 86750 13013 86500 13264 + 86250)) + 99798) + (test-success "example with 50 items" = knapsack + '(341045 + (4912 99732 56554 1818 108372 6750 1484 3072 13532 12050 + 18440 10972 1940 122094 5558 10630 2112 6942 39888 71276 + 8466 5662 231302 4690 18324 3384 7278 5566 706 10992 27552 + 7548 934 32038 1062 184848 2604 37644 1832 10306 1126 34886 + 3526 1196 1338 992 1390 56804 56804 634) + (1906 41516 23527 559 45136 2625 492 1086 5516 4875 7570 4436 + 620 50897 2129 4265 706 2721 16494 29688 3383 2181 96601 + 1795 7512 1242 2889 2133 103 4446 11326 3024 217 13269 281 + 77174 952 15572 566 4103 313 14393 1313 348 419 246 445 + 23552 23552 67)) + 142156))) + +(run-with-cli "knapsack.scm" (list test-cases)) diff --git a/exercises/practice/leap/.meta/config.json b/exercises/practice/leap/.meta/config.json index fc8fab87..3c0873d6 100644 --- a/exercises/practice/leap/.meta/config.json +++ b/exercises/practice/leap/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a year, report if it is a leap year.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "leap.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a year, report if it is a leap year.", "source": "JavaRanch Cattle Drive, exercise 3", "source_url": "http://www.javaranch.com/leap.jsp" } diff --git a/exercises/practice/leap/test-util.ss b/exercises/practice/leap/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/leap/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/leap/test.scm b/exercises/practice/leap/test.scm index 2a33746a..5e68d836 100644 --- a/exercises/practice/leap/test.scm +++ b/exercises/practice/leap/test.scm @@ -1,151 +1,31 @@ -(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 leap-year?) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "year not divisible by 4 in common year" eqv? - leap-year? '(2015) #f)) - (lambda () - (test-success - "year divisible by 2, not divisible by 4 in common year" - eqv? leap-year? '(1970) #f)) - (lambda () - (test-success - "year divisible by 4, not divisible by 100 in leap year" - eqv? leap-year? '(1996) #t)) - (lambda () - (test-success - "year divisible by 4 and 5 is still a leap year" eqv? - leap-year? '(1960) #t)) - (lambda () - (test-success - "year divisible by 100, not divisible by 400 in common year" - eqv? leap-year? '(2100) #f)) - (lambda () - (test-success - "year divisible by 100 but not by 3 is still not a leap year" - eqv? leap-year? '(1900) #f)) - (lambda () - (test-success "year divisible by 400 in leap year" eqv? - leap-year? '(2000) #t)) - (lambda () - (test-success - "year divisible by 400 but not by 125 is still a leap year" - eqv? leap-year? '(2400) #t)) - (lambda () - (test-success - "year divisible by 200, not divisible by 400 in common year" - eqv? leap-year? '(1800) #f)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) (load "leap.scm") (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "leap.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "year not divisible by 4 in common year" + eqv? leap-year? '(2015) #f) + (test-success + "year divisible by 2, not divisible by 4 in common year" + eqv? leap-year? '(1970) #f) + (test-success + "year divisible by 4, not divisible by 100 in leap year" + eqv? leap-year? '(1996) #t) + (test-success + "year divisible by 4 and 5 is still a leap year" eqv? + leap-year? '(1960) #t) + (test-success + "year divisible by 100, not divisible by 400 in common year" + eqv? leap-year? '(2100) #f) + (test-success + "year divisible by 100 but not by 3 is still not a leap year" + eqv? leap-year? '(1900) #f) + (test-success "year divisible by 400 in leap year" eqv? + leap-year? '(2000) #t) + (test-success + "year divisible by 400 but not by 125 is still a leap year" + eqv? leap-year? '(2400) #t) + (test-success + "year divisible by 200, not divisible by 400 in common year" + eqv? leap-year? '(1800) #f))) + +(run-with-cli "leap.scm" (list test-cases)) diff --git a/exercises/practice/list-ops/.meta/config.json b/exercises/practice/list-ops/.meta/config.json index 2292d4cb..49c92667 100644 --- a/exercises/practice/list-ops/.meta/config.json +++ b/exercises/practice/list-ops/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Implement basic list operations", "authors": [ "pminten" ], @@ -15,10 +14,12 @@ "list-ops.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] - } + }, + "blurb": "Implement basic list operations" } diff --git a/exercises/practice/list-ops/Makefile b/exercises/practice/list-ops/Makefile new file mode 100644 index 00000000..ea4c6c16 --- /dev/null +++ b/exercises/practice/list-ops/Makefile @@ -0,0 +1,17 @@ +solution := + +chez := scheme +guile := guile + +help : + echo 'Run make chez or make guile' + +check-all : chez guile + +chez : + $(chez) --script test.scm $(solution) + +guile : + $(guile) test.scm $(solution) + +.PHONY : help check-all chez guile diff --git a/exercises/practice/list-ops/test-util.ss b/exercises/practice/list-ops/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/list-ops/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/list-ops/test.scm b/exercises/practice/list-ops/test.scm index 9a05b153..c52814d9 100644 --- a/exercises/practice/list-ops/test.scm +++ b/exercises/practice/list-ops/test.scm @@ -1,124 +1,130 @@ -;; Load SRFI-64 lightweight testing specification +(load "test-util.ss") + (use-modules (srfi srfi-64)) + (use-modules (srfi srfi-1)) -;; Suppress log file output. To write logs, comment out the following line: -(module-define! (resolve-module '(srfi srfi-64)) 'test-log-to-file #f) +(module-define! + (resolve-module '(srfi srfi-64)) + 'test-log-to-file + #f) -;; Require list-ops impl (add-to-load-path (dirname (current-filename))) + (use-modules (list-ops)) -;;; Begin test suite (test-begin "list-ops-test") -(test-eqv "length of empty list" - 0 - (my-length '())) +(test-eqv "length of empty list" 0 (my-length '())) -(test-eqv "length of normal list" - 4 - (my-length '(1 3 5 7))) +(test-eqv "length of normal list" 4 (my-length '(1 3 5 7))) -(test-eqv "length of huge list" - 1000000 - (my-length (list-tabulate 1000000 values))) +(test-eqv + "length of huge list" + 1000000 + (my-length (list-tabulate 1000000 values))) -(test-equal "reverse of empty list" - '() - (my-reverse '())) +(test-equal "reverse of empty list" '() (my-reverse '())) -(test-equal "reverse of normal list" - '(7 5 3 1) - (my-reverse '(1 3 5 7))) +(test-equal + "reverse of normal list" + '(7 5 3 1) + (my-reverse '(1 3 5 7))) -(test-equal "reverse of huge list" - (list-tabulate 1000000 (lambda (x) (- 999999 x))) - (my-reverse (list-tabulate 1000000 values))) +(test-equal + "reverse of huge list" + (list-tabulate 1000000 (lambda (x) (- 999999 x))) + (my-reverse (list-tabulate 1000000 values))) (define (inc x) (+ 1 x)) -(test-equal "map of empty list" - '() - (my-map inc '())) - -(test-equal "map of normal list" - '(2 3 4 5) - (my-map inc '(1 2 3 4))) - -(test-equal "map of huge list" - (list-tabulate 1000000 (lambda (x) (+ x 1))) - (my-map inc (list-tabulate 1000000 values))) - -(test-equal "filter of empty list" - '() - (my-filter odd? '())) - -(test-equal "filter of normal list" - '(1 3) - (my-filter odd? '(1 2 3 4))) - -(test-equal "filter of huge list" - (filter odd? (list-tabulate 1000000 values)) - (my-filter odd? (list-tabulate 1000000 values))) - -(test-eqv "fold of empty list" - 0 - (my-fold + 0 '())) - -(test-eqv "fold of normal list" - 7 - (my-fold + -3 '(1 2 3 4))) - -(test-eqv "fold of huge list" - (fold + 0 (list-tabulate 1000000 values)) - (my-fold + 0 (list-tabulate 1000000 values))) +(test-equal "map of empty list" '() (my-map inc '())) + +(test-equal + "map of normal list" + '(2 3 4 5) + (my-map inc '(1 2 3 4))) + +(test-equal + "map of huge list" + (list-tabulate 1000000 (lambda (x) (+ x 1))) + (my-map inc (list-tabulate 1000000 values))) + +(test-equal "filter of empty list" '() (my-filter odd? '())) + +(test-equal + "filter of normal list" + '(1 3) + (my-filter odd? '(1 2 3 4))) + +(test-equal + "filter of huge list" + (filter odd? (list-tabulate 1000000 values)) + (my-filter odd? (list-tabulate 1000000 values))) + +(test-eqv "fold of empty list" 0 (my-fold + 0 '())) + +(test-eqv "fold of normal list" 7 (my-fold + -3 '(1 2 3 4))) + +(test-eqv + "fold of huge list" + (fold + 0 (list-tabulate 1000000 values)) + (my-fold + 0 (list-tabulate 1000000 values))) + +(test-eqv + "fold with non-commutative function" + 0 + (my-fold (lambda (x acc) (- acc x)) 10 '(1 2 3 4))) + +(test-equal "append of empty lists" '() (my-append '() '())) + +(test-equal + "append of empty and non-empty list" + '(1 2 3 4) + (my-append '() '(1 2 3 4))) + +(test-equal + "append of non-empty and empty list" + '(1 2 3 4) + (my-append '(1 2 3 4) '())) + +(test-equal + "append of non-empty lists" + '(1 2 3 4 5) + (my-append '(1 2 3) '(4 5))) + +(test-equal + "append of huge lists" + (list-tabulate 2000000 values) + (my-append + (list-tabulate 1000000 values) + (list-tabulate 1000000 (lambda (x) (+ x 1000000))))) + +(test-equal + "concatenate of empty list of lists" + '() + (my-concatenate '())) + +(test-equal + "concatenate of normal list of lists" + '(1 2 3 4 5 6) + (my-concatenate '((1 2) (3) () (4 5 6)))) + +(test-equal + "concatenate of huge list of small lists" + (list-tabulate 1000000 values) + (my-concatenate (list-tabulate 1000000 list))) + +(test-equal + "concatenate of small list of huge lists" + (list-tabulate 1000000 values) + (my-concatenate + (list-tabulate + 10 + (lambda (i) + (list-tabulate 100000 (lambda (j) (+ (* 100000 i) j))))))) -(test-eqv "fold with non-commutative function" - 0 - (my-fold (lambda (x acc) (- acc x)) - 10 - '(1 2 3 4))) - -(test-equal "append of empty lists" - '() - (my-append '() '())) - -(test-equal "append of empty and non-empty list" - '(1 2 3 4) - (my-append '() '(1 2 3 4))) - -(test-equal "append of non-empty and empty list" - '(1 2 3 4) - (my-append '(1 2 3 4) '())) - -(test-equal "append of non-empty lists" - '(1 2 3 4 5) - (my-append '(1 2 3) '(4 5))) - -(test-equal "append of huge lists" - (list-tabulate 2000000 values) - (my-append (list-tabulate 1000000 values) - (list-tabulate 1000000 (lambda (x) (+ x 1000000))))) - -(test-equal "concatenate of empty list of lists" - '() - (my-concatenate '())) - -(test-equal "concatenate of normal list of lists" - '(1 2 3 4 5 6) - (my-concatenate '((1 2) (3) () (4 5 6)))) - -(test-equal "concatenate of huge list of small lists" - (list-tabulate 1000000 values) - (my-concatenate (list-tabulate 1000000 list))) +(test-end "list-ops-test") -(test-equal "concatenate of small list of huge lists" - (list-tabulate 1000000 values) - (my-concatenate - (list-tabulate 10 (lambda (i) - (list-tabulate 100000 - (lambda (j) (+ (* 100000 i) j))))))) +(run-with-cli "list-ops.scm" (list test-cases)) -(test-end "list-ops-test") -;;; End test suite diff --git a/exercises/practice/matching-brackets/.meta/config.json b/exercises/practice/matching-brackets/.meta/config.json index da6a7716..f0e60b49 100644 --- a/exercises/practice/matching-brackets/.meta/config.json +++ b/exercises/practice/matching-brackets/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Make sure the brackets and braces all match.", "authors": [ "jitwit" ], @@ -8,11 +7,13 @@ "matching-brackets.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Make sure the brackets and braces all match.", "source": "Ginna Baker" } diff --git a/exercises/practice/matching-brackets/test-util.ss b/exercises/practice/matching-brackets/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/matching-brackets/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/matching-brackets/test.scm b/exercises/practice/matching-brackets/test.scm index 97ffb863..2b81de6f 100644 --- a/exercises/practice/matching-brackets/test.scm +++ b/exercises/practice/matching-brackets/test.scm @@ -1,169 +1,38 @@ -(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 balanced?) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "paired square brackets" eq? balanced? '("[]") - #t)) - (lambda () - (test-success "empty string" eq? balanced? '("") #t)) - (lambda () - (test-success "unpaired brackets" eq? balanced? '("[[") #f)) - (lambda () - (test-success "wrong ordered brackets" eq? balanced? '("}{") - #f)) - (lambda () - (test-success "wrong closing bracket" eq? balanced? '("{]") - #f)) - (lambda () - (test-success "paired with whitespace" eq? balanced? - '("{ }") #t)) - (lambda () - (test-success "partially paired brackets" eq? balanced? - '("{[])") #f)) - (lambda () - (test-success "simple nested brackets" eq? balanced? - '("{[]}") #t)) - (lambda () - (test-success "several paired brackets" eq? balanced? - '("{}[]") #t)) - (lambda () - (test-success "paired and nested brackets" eq? balanced? - '("([{}({}[])])") #t)) - (lambda () - (test-success "unopened closing brackets" eq? balanced? - '("{[)][]}") #f)) - (lambda () - (test-success "unpaired and nested brackets" eq? balanced? - '("([{])") #f)) - (lambda () - (test-success "paired and wrong nested brackets" eq? - balanced? '("[({]})") #f)) - (lambda () - (test-success "paired and incomplete brackets" eq? balanced? - '("{}[") #f)) - (lambda () - (test-success "too many closing brackets" eq? balanced? - '("[]]") #f)) - (lambda () - (test-success "math expression" eq? balanced? - '("(((185 + 223.85) * 15) - 543)/2") #t)) - (lambda () - (test-success "complex latex expression" eq? balanced? - '("\\left(\\begin{array}{cc} \\frac{1}{3} & x\\\\ \\mathrm{e}^{x} &... x^2 \\end{array}\\right)") - #t)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "matching-brackets.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "matching-brackets.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "paired square brackets" eq? balanced? + '("[]") #t) (test-success "empty string" eq? balanced? '("") #t) + (test-success "unpaired brackets" eq? balanced? '("[[") #f) + (test-success "wrong ordered brackets" eq? balanced? '("}{") + #f) + (test-success "wrong closing bracket" eq? balanced? '("{]") + #f) + (test-success "paired with whitespace" eq? balanced? + '("{ }") #t) + (test-success "partially paired brackets" eq? balanced? + '("{[])") #f) + (test-success "simple nested brackets" eq? balanced? + '("{[]}") #t) + (test-success "several paired brackets" eq? balanced? + '("{}[]") #t) + (test-success "paired and nested brackets" eq? balanced? + '("([{}({}[])])") #t) + (test-success "unopened closing brackets" eq? balanced? + '("{[)][]}") #f) + (test-success "unpaired and nested brackets" eq? balanced? + '("([{])") #f) + (test-success "paired and wrong nested brackets" eq? + balanced? '("[({]})") #f) + (test-success "paired and incomplete brackets" eq? balanced? + '("{}[") #f) + (test-success "too many closing brackets" eq? balanced? + '("[]]") #f) + (test-success "math expression" eq? balanced? + '("(((185 + 223.85) * 15) - 543)/2") #t) + (test-success "complex latex expression" eq? balanced? + '("\\left(\\begin{array}{cc} \\frac{1}{3} & x\\\\ \\mathrm{e}^{x} &... x^2 \\end{array}\\right)") + #t))) + +(run-with-cli "matching-brackets.scm" (list test-cases)) diff --git a/exercises/practice/nucleotide-count/.meta/config.json b/exercises/practice/nucleotide-count/.meta/config.json index ddd00426..fd0c319c 100644 --- a/exercises/practice/nucleotide-count/.meta/config.json +++ b/exercises/practice/nucleotide-count/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a DNA string, compute how many times each nucleotide occurs in the string.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "nucleotide-count.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a DNA string, compute how many times each nucleotide occurs in the string.", "source": "The Calculating DNA Nucleotides_problem at Rosalind", "source_url": "http://rosalind.info/problems/dna/" } diff --git a/exercises/practice/nucleotide-count/test-util.ss b/exercises/practice/nucleotide-count/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/nucleotide-count/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/nucleotide-count/test.scm b/exercises/practice/nucleotide-count/test.scm index 34b84db1..302e542e 100644 --- a/exercises/practice/nucleotide-count/test.scm +++ b/exercises/practice/nucleotide-count/test.scm @@ -1,197 +1,79 @@ -(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 nucleotide-count) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "empty strand" - (lambda (xs ys) - (letrec ([make-list (lambda (x n) - (if (zero? n) - '() - (cons x (make-list x (- n 1)))))] - [count->list (lambda (z) - (list-sort - charlist xs) (count->list ys)))) - nucleotide-count '("") - '((#\A . 0) (#\C . 0) (#\G . 0) (#\T . 0)))) - (lambda () - (test-success "can count one nucleotide in single-character input" - (lambda (xs ys) - (letrec ([make-list (lambda (x n) - (if (zero? n) - '() - (cons x (make-list x (- n 1)))))] - [count->list (lambda (z) - (list-sort - charlist xs) (count->list ys)))) - nucleotide-count '("G") - '((#\A . 0) (#\C . 0) (#\G . 1) (#\T . 0)))) - (lambda () - (test-success "strand with repeated nucleotide" - (lambda (xs ys) - (letrec ([make-list (lambda (x n) - (if (zero? n) - '() - (cons x (make-list x (- n 1)))))] - [count->list (lambda (z) - (list-sort - charlist xs) (count->list ys)))) - nucleotide-count '("GGGGGGG") - '((#\A . 0) (#\C . 0) (#\G . 7) (#\T . 0)))) - (lambda () - (test-success "strand with multiple nucleotides" - (lambda (xs ys) - (letrec ([make-list (lambda (x n) - (if (zero? n) - '() - (cons x (make-list x (- n 1)))))] - [count->list (lambda (z) - (list-sort - charlist xs) (count->list ys)))) - nucleotide-count - '("AGCTTTTCATTCTGACTGCAACGGGCAATATGTCTCTGTGTGGATTAAAAAAAGAGTGTCTGATAGCAGC") - '((#\A . 20) (#\C . 12) (#\G . 17) (#\T . 21)))) - (lambda () - (test-error - "strand with invalid nucleotides" - nucleotide-count - '("AGXXACT"))))) - -(define (test . query) - (apply run-test-suite test-cases query)) + `((test-success "empty strand" + (lambda (xs ys) + (letrec ([make-list (lambda (x n) + (if (zero? n) + '() + (cons x (make-list x (- n 1)))))] + [count->list (lambda (z) + (list-sort + charlist xs) (count->list ys)))) + nucleotide-count '("") + '((#\A . 0) (#\C . 0) (#\G . 0) (#\T . 0))) + (test-success "can count one nucleotide in single-character input" + (lambda (xs ys) + (letrec ([make-list (lambda (x n) + (if (zero? n) + '() + (cons x (make-list x (- n 1)))))] + [count->list (lambda (z) + (list-sort + charlist xs) (count->list ys)))) + nucleotide-count '("G") + '((#\A . 0) (#\C . 0) (#\G . 1) (#\T . 0))) + (test-success "strand with repeated nucleotide" + (lambda (xs ys) + (letrec ([make-list (lambda (x n) + (if (zero? n) + '() + (cons x (make-list x (- n 1)))))] + [count->list (lambda (z) + (list-sort + charlist xs) (count->list ys)))) + nucleotide-count '("GGGGGGG") + '((#\A . 0) (#\C . 0) (#\G . 7) (#\T . 0))) + (test-success "strand with multiple nucleotides" + (lambda (xs ys) + (letrec ([make-list (lambda (x n) + (if (zero? n) + '() + (cons x (make-list x (- n 1)))))] + [count->list (lambda (z) + (list-sort + charlist xs) (count->list ys)))) + nucleotide-count + '("AGCTTTTCATTCTGACTGCAACGGGCAATATGTCTCTGTGTGGATTAAAAAAAGAGTGTCTGATAGCAGC") + '((#\A . 20) (#\C . 12) (#\G . 17) (#\T . 21))) + (test-error + "strand with invalid nucleotides" + nucleotide-count + '("AGXXACT")))) -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "nucleotide-count.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "nucleotide-count.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) +(run-with-cli "nucleotide-count.scm" (list test-cases)) diff --git a/exercises/practice/octal/.meta/config.json b/exercises/practice/octal/.meta/config.json index ddc246cf..464b3508 100644 --- a/exercises/practice/octal/.meta/config.json +++ b/exercises/practice/octal/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Convert a octal number, represented as a string (e.g. '1735263'), to its decimal equivalent using first principles (i.e. no, you may not use built-in or external libraries to accomplish the conversion).", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "octal.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Convert a octal number, represented as a string (e.g. '1735263'), to its decimal equivalent using first principles (i.e. no, you may not use built-in or external libraries to accomplish the conversion).", "source": "All of Computer Science", "source_url": "http://www.wolframalpha.com/input/?i=base+8" } diff --git a/exercises/practice/octal/test-util.ss b/exercises/practice/octal/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/octal/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/octal/test.scm b/exercises/practice/octal/test.scm index b8a752e2..a03442e6 100644 --- a/exercises/practice/octal/test.scm +++ b/exercises/practice/octal/test.scm @@ -1,154 +1,36 @@ -(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 to-decimal) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "octal 1 is decimal 1" equal? to-decimal '("1") 1)) - (lambda () - (test-success "octal 2 is decimal 2" equal? to-decimal '("2") 2)) - (lambda () - (test-success "octal 10 is decimal 8" equal? to-decimal '("10") 8)) - (lambda () - (test-success "octal 11 is decimal 9" equal? to-decimal '("11") 9)) - (lambda () - (test-success "octal 17 is deciaml 15" equal? to-decimal '("17") 15)) - (lambda () - (test-success "octal 130 is decimal 88" equal? to-decimal '("130") 88)) - (lambda () - (test-success "octal 2047 is decimal 1063" equal? to-decimal - '("2047") 1063)) - (lambda () - (test-success "octal 7777 is decimal 4095" equal? to-decimal - '("7777") 4095)) - (lambda () - (test-success "octal 1234567 is decimal 342391" equal? to-decimal - '("1234567") 342391)) - (lambda () - (test-success "invalid input is decimal 0" equal? to-decimal - '("carrot should be invalid") 0)) - (lambda () - (test-success "8 is invalid octal" equal? to-decimal '("8") 0)) - (lambda () - (test-success "9 is invalid octal" equal? to-decimal '("9") 0)) - (lambda () - (test-success "6789 is invalid octal" equal? to-decimal '("6789") 0)) - (lambda () - (test-success "abc1z is invalid octal" equal? to-decimal '("abc1z") 0)) - (lambda () - (test-success "leading zero is valid octal" equal? to-decimal - '("011") 9)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "octal.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "octal.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "octal 1 is decimal 1" equal? to-decimal + '("1") 1) + (test-success "octal 2 is decimal 2" equal? to-decimal + '("2") 2) + (test-success "octal 10 is decimal 8" equal? to-decimal + '("10") 8) + (test-success "octal 11 is decimal 9" equal? to-decimal + '("11") 9) + (test-success "octal 17 is deciaml 15" equal? to-decimal + '("17") 15) + (test-success "octal 130 is decimal 88" equal? to-decimal + '("130") 88) + (test-success "octal 2047 is decimal 1063" equal? to-decimal + '("2047") 1063) + (test-success "octal 7777 is decimal 4095" equal? to-decimal + '("7777") 4095) + (test-success "octal 1234567 is decimal 342391" equal? + to-decimal '("1234567") 342391) + (test-success "invalid input is decimal 0" equal? to-decimal + '("carrot should be invalid") 0) + (test-success "8 is invalid octal" equal? to-decimal '("8") + 0) + (test-success "9 is invalid octal" equal? to-decimal '("9") + 0) + (test-success "6789 is invalid octal" equal? to-decimal + '("6789") 0) + (test-success "abc1z is invalid octal" equal? to-decimal + '("abc1z") 0) + (test-success "leading zero is valid octal" equal? + to-decimal '("011") 9))) + +(run-with-cli "octal.scm" (list test-cases)) diff --git a/exercises/practice/pangram/.meta/config.json b/exercises/practice/pangram/.meta/config.json index c8918f5b..1b24c97d 100644 --- a/exercises/practice/pangram/.meta/config.json +++ b/exercises/practice/pangram/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Determine if a sentence is a pangram.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "pangram.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Determine if a sentence is a pangram.", "source": "Wikipedia", "source_url": "https://en.wikipedia.org/wiki/Pangram" } diff --git a/exercises/practice/pangram/test-util.ss b/exercises/practice/pangram/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/pangram/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/pangram/test.scm b/exercises/practice/pangram/test.scm index d2df8810..6bc8ae11 100644 --- a/exercises/practice/pangram/test.scm +++ b/exercises/practice/pangram/test.scm @@ -1,149 +1,26 @@ -(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 pangram?) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "empty sentence" eq? pangram? '("") #f)) - (lambda () - (test-success "perfect lower case" eq? pangram? - '("abcdefghijklmnopqrstuvwxyz") #t)) - (lambda () - (test-success "only lower case" eq? pangram? - '("the quick brown fox jumps over the lazy dog") #t)) - (lambda () - (test-success "missing the letter 'x'" eq? pangram? - '("a quick movement of the enemy will jeopardize five gunboats") - #f)) - (lambda () - (test-success "missing the letter 'h'" eq? pangram? - '("five boxing wizards jump quickly at it") #f)) - (lambda () - (test-success "with underscores" eq? pangram? - '("the_quick_brown_fox_jumps_over_the_lazy_dog") #t)) - (lambda () - (test-success "with numbers" eq? pangram? - '("the 1 quick brown fox jumps over the 2 lazy dogs") #t)) - (lambda () - (test-success "missing letters replaced by numbers" eq? pangram? - '("7h3 qu1ck brown fox jumps ov3r 7h3 lazy dog") #f)) - (lambda () - (test-success "mixed case and punctuation" eq? pangram? - '("\"Five quacking Zephyrs jolt my wax bed.\"") #t)) - (lambda () - (test-success "case insensitive" eq? pangram? - '("the quick brown fox jumps over with lazy FX") #f)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "pangram.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "pangram.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "empty sentence" eq? pangram? '("") #f) + (test-success "perfect lower case" eq? pangram? + '("abcdefghijklmnopqrstuvwxyz") #t) + (test-success "only lower case" eq? pangram? + '("the quick brown fox jumps over the lazy dog") #t) + (test-success "missing the letter 'x'" eq? pangram? + '("a quick movement of the enemy will jeopardize five gunboats") + #f) + (test-success "missing the letter 'h'" eq? pangram? + '("five boxing wizards jump quickly at it") #f) + (test-success "with underscores" eq? pangram? + '("the_quick_brown_fox_jumps_over_the_lazy_dog") #t) + (test-success "with numbers" eq? pangram? + '("the 1 quick brown fox jumps over the 2 lazy dogs") #t) + (test-success "missing letters replaced by numbers" eq? pangram? + '("7h3 qu1ck brown fox jumps ov3r 7h3 lazy dog") #f) + (test-success "mixed case and punctuation" eq? pangram? + '("\"Five quacking Zephyrs jolt my wax bed.\"") #t) + (test-success "case insensitive" eq? pangram? + '("the quick brown fox jumps over with lazy FX") #f))) + +(run-with-cli "pangram.scm" (list test-cases)) diff --git a/exercises/practice/pascals-triangle/.meta/config.json b/exercises/practice/pascals-triangle/.meta/config.json index 8dc8ebfe..6c4b83e3 100644 --- a/exercises/practice/pascals-triangle/.meta/config.json +++ b/exercises/practice/pascals-triangle/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Compute Pascal's triangle up to a given number of rows.", "authors": [ "jitwit" ], @@ -11,12 +10,14 @@ "pascals-triangle.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Compute Pascal's triangle up to a given number of rows.", "source": "Pascal's Triangle at Wolfram Math World", "source_url": "http://mathworld.wolfram.com/PascalsTriangle.html" } diff --git a/exercises/practice/pascals-triangle/test-util.ss b/exercises/practice/pascals-triangle/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/pascals-triangle/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/pascals-triangle/test.scm b/exercises/practice/pascals-triangle/test.scm index 4e759e94..d5f17aee 100644 --- a/exercises/practice/pascals-triangle/test.scm +++ b/exercises/practice/pascals-triangle/test.scm @@ -1,144 +1,24 @@ -(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 pascals-triangle) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "zero rows" equal? pascals-triangle '(0) '())) - (lambda () - (test-success "single row" equal? pascals-triangle '(1) - '((1)))) - (lambda () - (test-success "two rows" equal? pascals-triangle '(2) - '((1) (1 1)))) - (lambda () - (test-success "three rows" equal? pascals-triangle '(3) - '((1) (1 1) (1 2 1)))) - (lambda () - (test-success "four rows" equal? pascals-triangle '(4) - '((1) (1 1) (1 2 1) (1 3 3 1)))) - (lambda () - (test-success "five rows" equal? pascals-triangle '(5) - '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1)))) - (lambda () - (test-success "six rows" equal? pascals-triangle '(6) - '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1) (1 5 10 10 5 1)))) - (lambda () - (test-success "ten rows" equal? pascals-triangle '(10) - '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1) (1 5 10 10 5 1) - (1 6 15 20 15 6 1) (1 7 21 35 35 21 7 1) - (1 8 28 56 70 56 28 8 1) (1 9 36 84 126 126 84 36 9 1)))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "pascals-triangle.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "pascals-triangle.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "zero rows" equal? pascals-triangle '(0) + '()) + (test-success "single row" equal? pascals-triangle '(1) + '((1))) + (test-success "two rows" equal? pascals-triangle '(2) + '((1) (1 1))) + (test-success "three rows" equal? pascals-triangle '(3) + '((1) (1 1) (1 2 1))) + (test-success "four rows" equal? pascals-triangle '(4) + '((1) (1 1) (1 2 1) (1 3 3 1))) + (test-success "five rows" equal? pascals-triangle '(5) + '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1))) + (test-success "six rows" equal? pascals-triangle '(6) + '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1) (1 5 10 10 5 1))) + (test-success "ten rows" equal? pascals-triangle '(10) + '((1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1) (1 5 10 10 5 1) + (1 6 15 20 15 6 1) (1 7 21 35 35 21 7 1) + (1 8 28 56 70 56 28 8 1) (1 9 36 84 126 126 84 36 9 1))))) + +(run-with-cli "pascals-triangle.scm" (list test-cases)) diff --git a/exercises/practice/perfect-numbers/.meta/config.json b/exercises/practice/perfect-numbers/.meta/config.json index 4c57d048..02d9d970 100644 --- a/exercises/practice/perfect-numbers/.meta/config.json +++ b/exercises/practice/perfect-numbers/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Determine if a number is perfect, abundant, or deficient based on Nicomachus' (60 - 120 CE) classification scheme for positive integers.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "perfect-numbers.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Determine if a number is perfect, abundant, or deficient based on Nicomachus' (60 - 120 CE) classification scheme for positive integers.", "source": "Taken from Chapter 2 of Functional Thinking by Neal Ford.", "source_url": "http://shop.oreilly.com/product/0636920029687.do" } diff --git a/exercises/practice/perfect-numbers/test-util.ss b/exercises/practice/perfect-numbers/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/perfect-numbers/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/perfect-numbers/test.scm b/exercises/practice/perfect-numbers/test.scm index 0e6b1e36..e00c127d 100644 --- a/exercises/practice/perfect-numbers/test.scm +++ b/exercises/practice/perfect-numbers/test.scm @@ -1,172 +1,46 @@ -(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 classify) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success - "Smallest perfect number is classified correctly" eq? - classify '(6) 'perfect)) - (lambda () - (test-success - "Medium perfect number is classified correctly" eq? classify - '(28) 'perfect)) - (lambda () - (test-success "Large perfect number is classified correctly" - eq? classify '(33550336) 'perfect)) - (lambda () - (test-success - "Smallest abundant number is classified correctly" eq? - classify '(12) 'abundant)) - (lambda () - (test-success - "Medium abundant number is classified correctly" eq? - classify '(30) 'abundant)) - (lambda () - (test-success - "Large abundant number is classified correctly" eq? classify - '(33550335) 'abundant)) - (lambda () - (test-success - "Smallest prime deficient number is classified correctly" - eq? classify '(2) 'deficient)) - (lambda () - (test-success - "Smallest non-prime deficient number is classified correctly" - eq? classify '(4) 'deficient)) - (lambda () - (test-success - "Medium deficient number is classified correctly" eq? - classify '(32) 'deficient)) - (lambda () - (test-success - "Large deficient number is classified correctly" eq? - classify '(33550337) 'deficient)) - (lambda () - (test-success - "Edge case (no factors other than itself) is classified correctly" - eq? classify '(1) 'deficient)) - (lambda () - (test-error - "Zero is rejected (not a natural number)" - classify - '(0))) - (lambda () - (test-error - "Negative integer is rejected (not a natural number)" - classify - '(-1))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "perfect-numbers.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "perfect-numbers.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success + "Smallest perfect number is classified correctly" eq? + classify '(6) 'perfect) + (test-success + "Medium perfect number is classified correctly" eq? classify + '(28) 'perfect) + (test-success "Large perfect number is classified correctly" + eq? classify '(33550336) 'perfect) + (test-success + "Smallest abundant number is classified correctly" eq? + classify '(12) 'abundant) + (test-success + "Medium abundant number is classified correctly" eq? + classify '(30) 'abundant) + (test-success + "Large abundant number is classified correctly" eq? classify + '(33550335) 'abundant) + (test-success + "Smallest prime deficient number is classified correctly" + eq? classify '(2) 'deficient) + (test-success + "Smallest non-prime deficient number is classified correctly" + eq? classify '(4) 'deficient) + (test-success + "Medium deficient number is classified correctly" eq? + classify '(32) 'deficient) + (test-success + "Large deficient number is classified correctly" eq? + classify '(33550337) 'deficient) + (test-success + "Edge case (no factors other than itself) is classified correctly" + eq? classify '(1) 'deficient) + (test-error + "Zero is rejected (not a natural number)" + classify + '(0)) + (test-error + "Negative integer is rejected (not a natural number)" + classify + '(-1)))) + +(run-with-cli "perfect-numbers.scm" (list test-cases)) diff --git a/exercises/practice/phone-number/.meta/config.json b/exercises/practice/phone-number/.meta/config.json index 00e0f0fc..1c72d809 100644 --- a/exercises/practice/phone-number/.meta/config.json +++ b/exercises/practice/phone-number/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Clean up user-entered phone numbers so that they can be sent SMS messages.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "phone-number.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Clean up user-entered phone numbers so that they can be sent SMS messages.", "source": "Event Manager by JumpstartLab", "source_url": "http://tutorials.jumpstartlab.com/projects/eventmanager.html" } diff --git a/exercises/practice/phone-number/test-util.ss b/exercises/practice/phone-number/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/phone-number/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/phone-number/test.scm b/exercises/practice/phone-number/test.scm index 1007e68a..f27ef1b5 100644 --- a/exercises/practice/phone-number/test.scm +++ b/exercises/practice/phone-number/test.scm @@ -1,194 +1,63 @@ -(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 clean) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "cleans the number" equal? clean - '("(223) 456-7890") "2234567890")) - (lambda () - (test-success "cleans numbers with dots" equal? clean - '("223.456.7890") "2234567890")) - (lambda () - (test-success "cleans numbers with multiple spaces" equal? - clean '("223 456 7890 ") "2234567890")) - (lambda () - (test-error "invalid when 9 digits" clean '("123456789"))) - (lambda () - (test-error - "invalid when 11 digits does not start with a 1" - clean - '("22234567890"))) - (lambda () - (test-success "valid when 11 digits and starting with 1" - equal? clean '("12234567890") "2234567890")) - (lambda () - (test-success - "valid when 11 digits and starting with 1 even with punctuation" - equal? clean '("+1 (223) 456-7890") "2234567890")) - (lambda () - (test-error - "invalid when more than 11 digits" - clean - '("321234567890"))) - (lambda () - (test-error "invalid with letters" clean '("123-abc-7890"))) - (lambda () - (test-error - "invalid with punctuations" - clean - '("123-@:!-7890"))) - (lambda () - (test-error - "invalid if area code starts with 0" - clean - '("(023) 456-7890"))) - (lambda () - (test-error - "invalid if area code starts with 1" - clean - '("(123) 456-7890"))) - (lambda () - (test-error - "invalid if exchange code starts with 0" - clean - '("(223) 056-7890"))) - (lambda () - (test-error - "invalid if exchange code starts with 1" - clean - '("(223) 156-7890"))) - (lambda () - (test-error - "invalid if area code starts with 0 on valid 11-digit number" - clean - '("1 (023) 456-7890"))) - (lambda () - (test-error - "invalid if area code starts with 1 on valid 11-digit number" - clean - '("1 (123) 456-7890"))) - (lambda () - (test-error - "invalid if exchange code starts with 0 on valid 11-digit number" - clean - '("1 (223) 056-7890"))) - (lambda () - (test-error - "invalid if exchange code starts with 1 on valid 11-digit number" - clean - '("1 (223) 156-7890"))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "phone-number.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "phone-number.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "cleans the number" equal? clean + '("(223) 456-7890") "2234567890") + (test-success "cleans numbers with dots" equal? clean + '("223.456.7890") "2234567890") + (test-success "cleans numbers with multiple spaces" equal? + clean '("223 456 7890 ") "2234567890") + (test-error "invalid when 9 digits" clean '("123456789")) + (test-error + "invalid when 11 digits does not start with a 1" + clean + '("22234567890")) + (test-success "valid when 11 digits and starting with 1" + equal? clean '("12234567890") "2234567890") + (test-success + "valid when 11 digits and starting with 1 even with punctuation" + equal? clean '("+1 (223) 456-7890") "2234567890") + (test-error + "invalid when more than 11 digits" + clean + '("321234567890")) + (test-error "invalid with letters" clean '("123-abc-7890")) + (test-error + "invalid with punctuations" + clean + '("123-@:!-7890")) + (test-error + "invalid if area code starts with 0" + clean + '("(023) 456-7890")) + (test-error + "invalid if area code starts with 1" + clean + '("(123) 456-7890")) + (test-error + "invalid if exchange code starts with 0" + clean + '("(223) 056-7890")) + (test-error + "invalid if exchange code starts with 1" + clean + '("(223) 156-7890")) + (test-error + "invalid if area code starts with 0 on valid 11-digit number" + clean + '("1 (023) 456-7890")) + (test-error + "invalid if area code starts with 1 on valid 11-digit number" + clean + '("1 (123) 456-7890")) + (test-error + "invalid if exchange code starts with 0 on valid 11-digit number" + clean + '("1 (223) 056-7890")) + (test-error + "invalid if exchange code starts with 1 on valid 11-digit number" + clean + '("1 (223) 156-7890")))) + +(run-with-cli "phone-number.scm" (list test-cases)) diff --git a/exercises/practice/prime-factors/.meta/config.json b/exercises/practice/prime-factors/.meta/config.json index 58d4a895..3eb7a077 100644 --- a/exercises/practice/prime-factors/.meta/config.json +++ b/exercises/practice/prime-factors/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Compute the prime factors of a given natural number.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "prime-factors.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Compute the prime factors of a given natural number.", "source": "The Prime Factors Kata by Uncle Bob", "source_url": "http://butunclebob.com/ArticleS.UncleBob.ThePrimeFactorsKata" } diff --git a/exercises/practice/prime-factors/test-util.ss b/exercises/practice/prime-factors/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/prime-factors/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/prime-factors/test.scm b/exercises/practice/prime-factors/test.scm index 915855ff..0df5da6f 100644 --- a/exercises/practice/prime-factors/test.scm +++ b/exercises/practice/prime-factors/test.scm @@ -1,147 +1,27 @@ -(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 factorize) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no factors" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(1) '())) - (lambda () - (test-success "prime number" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(2) '(2))) - (lambda () - (test-success "square of a prime" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(9) '(3 3))) - (lambda () - (test-success "cube of a prime" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(8) '(2 2 2))) - (lambda () - (test-success "product of primes and non-primes" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(12) '(2 2 3))) - (lambda () - (test-success "product of primes" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(901255) '(5 17 23 461))) - (lambda () - (test-success "factors include a large prime" - (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) - factorize '(93819012551) '(11 9539 894119))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "prime-factors.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "prime-factors.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "no factors" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(1) '()) + (test-success "prime number" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(2) '(2)) + (test-success "square of a prime" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(9) '(3 3)) + (test-success "cube of a prime" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(8) '(2 2 2)) + (test-success "product of primes and non-primes" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(12) '(2 2 3)) + (test-success "product of primes" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(901255) '(5 17 23 461)) + (test-success "factors include a large prime" + (lambda (xs ys) (equal? (list-sort < xs) (list-sort < ys))) + factorize '(93819012551) '(11 9539 894119)))) + +(run-with-cli "prime-factors.scm" (list test-cases)) diff --git a/exercises/practice/queen-attack/.meta/config.json b/exercises/practice/queen-attack/.meta/config.json index c42a6808..fd4f2d41 100644 --- a/exercises/practice/queen-attack/.meta/config.json +++ b/exercises/practice/queen-attack/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given the position of two queens on a chess board, indicate whether or not they are positioned so that they can attack each other.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "queen-attack.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given the position of two queens on a chess board, indicate whether or not they are positioned so that they can attack each other.", "source": "J Dalbey's Programming Practice problems", "source_url": "http://users.csc.calpoly.edu/~jdalbey/103/Projects/ProgrammingPractice.html" } diff --git a/exercises/practice/queen-attack/test-util.ss b/exercises/practice/queen-attack/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/queen-attack/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/queen-attack/test.scm b/exercises/practice/queen-attack/test.scm index 9a971ea5..e5a7afec 100644 --- a/exercises/practice/queen-attack/test.scm +++ b/exercises/practice/queen-attack/test.scm @@ -1,140 +1,20 @@ -(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 attacking?) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "can not attack" eq? attacking? '((2 4) (6 6)) - #f)) - (lambda () - (test-success "can attack on same row" eq? attacking? - '((2 4) (2 6)) #t)) - (lambda () - (test-success "can attack on same column" eq? attacking? - '((4 5) (2 5)) #t)) - (lambda () - (test-success "can attack on first diagonal" eq? attacking? - '((2 2) (0 4)) #t)) - (lambda () - (test-success "can attack on second diagonal" eq? attacking? - '((2 2) (3 1)) #t)) - (lambda () - (test-success "can attack on third diagonal" eq? attacking? - '((2 2) (1 1)) #t)) - (lambda () - (test-success "can attack on fourth diagonal" eq? attacking? - '((1 7) (0 6)) #t)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "queen-attack.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "queen-attack.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "can not attack" eq? attacking? + '((2 4) (6 6)) #f) + (test-success "can attack on same row" eq? attacking? + '((2 4) (2 6)) #t) + (test-success "can attack on same column" eq? attacking? + '((4 5) (2 5)) #t) + (test-success "can attack on first diagonal" eq? attacking? + '((2 2) (0 4)) #t) + (test-success "can attack on second diagonal" eq? attacking? + '((2 2) (3 1)) #t) + (test-success "can attack on third diagonal" eq? attacking? + '((2 2) (1 1)) #t) + (test-success "can attack on fourth diagonal" eq? attacking? + '((1 7) (0 6)) #t))) + +(run-with-cli "queen-attack.scm" (list test-cases)) diff --git a/exercises/practice/raindrops/.meta/config.json b/exercises/practice/raindrops/.meta/config.json index 73c12766..dde41163 100644 --- a/exercises/practice/raindrops/.meta/config.json +++ b/exercises/practice/raindrops/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Convert a number to a string, the content of which depends on the number's factors.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "raindrops.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Convert a number to a string, the content of which depends on the number's factors.", "source": "A variation on FizzBuzz, a famous technical interview question that is intended to weed out potential candidates. That question is itself derived from Fizz Buzz, a popular children's game for teaching division.", "source_url": "https://en.wikipedia.org/wiki/Fizz_buzz" } diff --git a/exercises/practice/raindrops/test-util.ss b/exercises/practice/raindrops/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/raindrops/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/raindrops/test.scm b/exercises/practice/raindrops/test.scm index 66ffa5d0..039549bf 100644 --- a/exercises/practice/raindrops/test.scm +++ b/exercises/practice/raindrops/test.scm @@ -1,186 +1,55 @@ -(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 convert) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "the sound for 1 is 1" equal? convert '(1) - "1")) - (lambda () - (test-success "the sound for 3 is Pling" equal? convert '(3) - "Pling")) - (lambda () - (test-success "the sound for 5 is Plang" equal? convert '(5) - "Plang")) - (lambda () - (test-success "the sound for 7 is Plong" equal? convert '(7) - "Plong")) - (lambda () - (test-success - "the sound for 6 is Pling as it has a factor 3" equal? - convert '(6) "Pling")) - (lambda () - (test-success - "2 to the power 3 does not make a raindrop sound as 3 is the exponent not the base" - equal? convert '(8) "8")) - (lambda () - (test-success - "the sound for 9 is Pling as it has a factor 3" equal? - convert '(9) "Pling")) - (lambda () - (test-success - "the sound for 10 is Plang as it has a factor 5" equal? - convert '(10) "Plang")) - (lambda () - (test-success - "the sound for 14 is Plong as it has a factor of 7" equal? - convert '(14) "Plong")) - (lambda () - (test-success - "the sound for 15 is PlingPlang as it has factors 3 and 5" - equal? convert '(15) "PlingPlang")) - (lambda () - (test-success - "the sound for 21 is PlingPlong as it has factors 3 and 7" - equal? convert '(21) "PlingPlong")) - (lambda () - (test-success - "the sound for 25 is Plang as it has a factor 5" equal? - convert '(25) "Plang")) - (lambda () - (test-success - "the sound for 27 is Pling as it has a factor 3" equal? - convert '(27) "Pling")) - (lambda () - (test-success - "the sound for 35 is PlangPlong as it has factors 5 and 7" - equal? convert '(35) "PlangPlong")) - (lambda () - (test-success - "the sound for 49 is Plong as it has a factor 7" equal? - convert '(49) "Plong")) - (lambda () - (test-success "the sound for 52 is 52" equal? convert '(52) - "52")) - (lambda () - (test-success - "the sound for 105 is PlingPlangPlong as it has factors 3, 5 and 7" - equal? convert '(105) "PlingPlangPlong")) - (lambda () - (test-success - "the sound for 3125 is Plang as it has a factor 5" equal? - convert '(3125) "Plang")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "raindrops.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "raindrops.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "the sound for 1 is 1" equal? convert '(1) + "1") + (test-success "the sound for 3 is Pling" equal? convert '(3) + "Pling") + (test-success "the sound for 5 is Plang" equal? convert '(5) + "Plang") + (test-success "the sound for 7 is Plong" equal? convert '(7) + "Plong") + (test-success + "the sound for 6 is Pling as it has a factor 3" equal? + convert '(6) "Pling") + (test-success + "2 to the power 3 does not make a raindrop sound as 3 is the exponent not the base" + equal? convert '(8) "8") + (test-success + "the sound for 9 is Pling as it has a factor 3" equal? + convert '(9) "Pling") + (test-success + "the sound for 10 is Plang as it has a factor 5" equal? + convert '(10) "Plang") + (test-success + "the sound for 14 is Plong as it has a factor of 7" equal? + convert '(14) "Plong") + (test-success + "the sound for 15 is PlingPlang as it has factors 3 and 5" + equal? convert '(15) "PlingPlang") + (test-success + "the sound for 21 is PlingPlong as it has factors 3 and 7" + equal? convert '(21) "PlingPlong") + (test-success + "the sound for 25 is Plang as it has a factor 5" equal? + convert '(25) "Plang") + (test-success + "the sound for 27 is Pling as it has a factor 3" equal? + convert '(27) "Pling") + (test-success + "the sound for 35 is PlangPlong as it has factors 5 and 7" + equal? convert '(35) "PlangPlong") + (test-success + "the sound for 49 is Plong as it has a factor 7" equal? + convert '(49) "Plong") + (test-success "the sound for 52 is 52" equal? convert '(52) + "52") + (test-success + "the sound for 105 is PlingPlangPlong as it has factors 3, 5 and 7" + equal? convert '(105) "PlingPlangPlong") + (test-success + "the sound for 3125 is Plang as it has a factor 5" equal? + convert '(3125) "Plang"))) + +(run-with-cli "raindrops.scm" (list test-cases)) diff --git a/exercises/practice/rna-transcription/.meta/config.json b/exercises/practice/rna-transcription/.meta/config.json index ac1a7db6..2932abae 100644 --- a/exercises/practice/rna-transcription/.meta/config.json +++ b/exercises/practice/rna-transcription/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a DNA strand, return its RNA Complement Transcription.", "authors": [ "canweriotnow" ], @@ -14,12 +13,14 @@ "rna-transcription.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a DNA strand, return its RNA Complement Transcription.", "source": "Hyperphysics", "source_url": "http://hyperphysics.phy-astr.gsu.edu/hbase/Organic/transcription.html" } diff --git a/exercises/practice/rna-transcription/test-util.ss b/exercises/practice/rna-transcription/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/rna-transcription/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/rna-transcription/test.scm b/exercises/practice/rna-transcription/test.scm index 20a962af..113197e8 100644 --- a/exercises/practice/rna-transcription/test.scm +++ b/exercises/practice/rna-transcription/test.scm @@ -1,137 +1,18 @@ -(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 dna->rna) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "Empty RNA sequence" equal? dna->rna '("") - "")) - (lambda () - (test-success "RNA complement of cytosine is guanine" equal? - dna->rna '("C") "G")) - (lambda () - (test-success "RNA complement of guanine is cytosine" equal? - dna->rna '("G") "C")) - (lambda () - (test-success "RNA complement of thymine is adenine" equal? - dna->rna '("T") "A")) - (lambda () - (test-success "RNA complement of adenine is uracil" equal? - dna->rna '("A") "U")) - (lambda () - (test-success "RNA complement" equal? dna->rna - '("ACGTGGTCTTAA") "UGCACCAGAAUU")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "rna-transcription.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "rna-transcription.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "Empty RNA sequence" equal? dna->rna '("") + "") + (test-success "RNA complement of cytosine is guanine" equal? + dna->rna '("C") "G") + (test-success "RNA complement of guanine is cytosine" equal? + dna->rna '("G") "C") + (test-success "RNA complement of thymine is adenine" equal? + dna->rna '("T") "A") + (test-success "RNA complement of adenine is uracil" equal? + dna->rna '("A") "U") + (test-success "RNA complement" equal? dna->rna + '("ACGTGGTCTTAA") "UGCACCAGAAUU"))) + +(run-with-cli "rna-transcription.scm" (list test-cases)) diff --git a/exercises/practice/robot-name/.meta/config.json b/exercises/practice/robot-name/.meta/config.json index d6c6ab1d..36d1fd66 100644 --- a/exercises/practice/robot-name/.meta/config.json +++ b/exercises/practice/robot-name/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Manage robot factory settings.", "authors": [ "canweriotnow" ], @@ -20,5 +19,6 @@ ".meta/example.scm" ] }, + "blurb": "Manage robot factory settings.", "source": "A debugging session with Paul Blackwell at gSchool." } diff --git a/exercises/practice/robot-name/Makefile b/exercises/practice/robot-name/Makefile new file mode 100644 index 00000000..ea4c6c16 --- /dev/null +++ b/exercises/practice/robot-name/Makefile @@ -0,0 +1,17 @@ +solution := + +chez := scheme +guile := guile + +help : + echo 'Run make chez or make guile' + +check-all : chez guile + +chez : + $(chez) --script test.scm $(solution) + +guile : + $(guile) test.scm $(solution) + +.PHONY : help check-all chez guile diff --git a/exercises/practice/robot-name/test-util.ss b/exercises/practice/robot-name/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/robot-name/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/robot-name/test.scm b/exercises/practice/robot-name/test.scm index 132ed128..3babb46f 100644 --- a/exercises/practice/robot-name/test.scm +++ b/exercises/practice/robot-name/test.scm @@ -1,41 +1,53 @@ -;; Load SRFI-64 lightweight testing specification -(use-modules (srfi srfi-64)) +(load "test-util.ss") -;; Suppress log file output. To write logs, comment out the following line: -(module-define! (resolve-module '(srfi srfi-64)) 'test-log-to-file #f) +(define *robbie* (build-robot)) -;; Require module -(add-to-load-path (dirname (current-filename))) -(use-modules (robot)) +(define *clutz* (build-robot)) -(test-begin "robot-name") -(define *robbie* (build-robot)) -(define *clutz* (build-robot)) - -(test-assert "name matches expected pattern" - (let ((name (robot-name *robbie*))) - (and (eq? (string-length name) 5) - (string-every char-upper-case? (substring name 0 2)) - (string-every char-numeric? (substring name 2 5))))) - -(test-equal "name is persistent" - (robot-name *robbie*) - (robot-name *robbie*)) - -(test-assert "different robots have different names" - (not - (string=? - (robot-name *robbie*) - (robot-name *clutz*)))) - -(test-assert "name can be reset" - (let* ((robot (build-robot)) - (original-name (robot-name robot))) - (reset-name robot) - (not - (string=? - (robot-name robot) - original-name)))) - -(test-end "robot-name") +(define (any f xs) + (fold-left (lambda (r x) (or r (f x))) #f xs)) + +(define (every f xs) + (fold-left (lambda (r x) (and r (f x))) #t xs)) + +(define (string-any f s) + (any f (string->list s))) + +(define (string-every f s) + (every f (string->list s))) + + +(test-assert + "name matches expected pattern" + (let ([name (robot-name *robbie*)]) + (and (eq? (string-length name) 5) + (string-every char-upper-case? (substring name 0 2)) + (string-every char-numeric? (substring name 2 5))))) + +(test-equal + "name is persistent" + (robot-name *robbie*) + (robot-name *robbie*)) + +(test-assert + "different robots have different names" + (not (string=? (robot-name *robbie*) (robot-name *clutz*)))) + +(test-assert + "name can be reset" + (let* ([robot (build-robot)] + [original-name (robot-name robot)]) + (reset-name robot) + (not (string=? (robot-name robot) original-name)))) + +(define (robot-name? name) + (and (= (string-length name) 5) + (string-every char-upper-case? (substring name 0 2)) + (string-every char-numeric? (substring name 2 5)))) + +(define test-cases + `((test-success "name matches expected pattern" + (lambda ())))) + +(run-with-cli "robot-name.scm" (list test-cases)) diff --git a/exercises/practice/roman-numerals/.meta/config.json b/exercises/practice/roman-numerals/.meta/config.json index a40ac9d1..65393910 100644 --- a/exercises/practice/roman-numerals/.meta/config.json +++ b/exercises/practice/roman-numerals/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Write a function to convert from normal numbers to Roman Numerals.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "roman-numerals.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Write a function to convert from normal numbers to Roman Numerals.", "source": "The Roman Numeral Kata", "source_url": "http://codingdojo.org/cgi-bin/index.pl?KataRomanNumerals" } diff --git a/exercises/practice/roman-numerals/test-util.ss b/exercises/practice/roman-numerals/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/roman-numerals/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/roman-numerals/test.scm b/exercises/practice/roman-numerals/test.scm index 9eb3a5de..184afc95 100644 --- a/exercises/practice/roman-numerals/test.scm +++ b/exercises/practice/roman-numerals/test.scm @@ -1,180 +1,53 @@ -(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 roman) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "1 is a single I" equal? roman '(1) "I")) - (lambda () - (test-success "2 is two I's" equal? roman '(2) "II")) - (lambda () - (test-success "3 is three I's" equal? roman '(3) "III")) - (lambda () - (test-success "4, being 5 - 1, is IV" equal? roman '(4) "IV")) - (lambda () - (test-success "5 is a single V" equal? roman '(5) "V")) - (lambda () - (test-success "6, being 5 + 1, is VI" equal? roman '(6) "VI")) - (lambda () - (test-success "9, being 10 - 1, is IX" equal? roman '(9) "IX")) - (lambda () - (test-success "20 is two X's" equal? roman '(20) "XX")) - (lambda () - (test-success "27 is 10 + 10 + 5 + 1 + 1" equal? roman '(27) "XXVII")) - (lambda () - (test-success "48 is not 50 - 2 but rather 40 + 8" equal? roman - '(48) "XLVIII")) - (lambda () - (test-success "49 is not 40 + 5 + 4 but rather 50 - 10 + 10 - 1" equal? - roman '(49) "XLIX")) - (lambda () - (test-success "50 is a single L" equal? roman '(50) "L")) - (lambda () - (test-success "59 is 50 + 10 - 1" equal? roman '(59) "LIX")) - (lambda () - (test-success "60, being 50 + 10, is LX" equal? roman '(60) "LX")) - (lambda () - (test-success "90, being 100 - 10, is XC" equal? roman '(90) "XC")) - (lambda () - (test-success "93 is 100 - 10 + 1 + 1 + 1" equal? roman '(93) "XCIII")) - (lambda () - (test-success "100 is a single C" equal? roman '(100) "C")) - (lambda () - (test-success "141 is 100 + 50 - 10 + 1" equal? roman '(141) "CXLI")) - (lambda () - (test-success "163 is 100 + 50 + 10 + 1 + 1 + 1" equal? roman - '(163) "CLXIII")) - (lambda () - (test-success "400, being 500 - 100, is CD" equal? roman '(400) "CD")) - (lambda () - (test-success "402 is 500 - 100 + 2" equal? roman '(402) "CDII")) - (lambda () - (test-success "500 is a single D" equal? roman '(500) "D")) - (lambda () - (test-success "575 is 500 + 50 + 10 + 10 + 5" equal? roman - '(575) "DLXXV")) - (lambda () - (test-success "900, being 1000 - 100, is CM" equal? roman '(900) "CM")) - (lambda () - (test-success "911 is 1000 - 100 + 10 + 1" equal? roman '(911) "CMXI")) - (lambda () - (test-success "1000 is a single M" equal? roman '(1000) "M")) - (lambda () - (test-success "1024 is 1000 + 10 + 10 + 5 - 1" equal? roman - '(1024) "MXXIV")) - (lambda () - (test-success "3000 is three M's" equal? roman '(3000) "MMM")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "roman-numerals.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "roman-numerals.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "1 is a single I" equal? roman '(1) "I") + (test-success "2 is two I's" equal? roman '(2) "II") + (test-success "3 is three I's" equal? roman '(3) "III") + (test-success "4, being 5 - 1, is IV" equal? roman '(4) + "IV") + (test-success "5 is a single V" equal? roman '(5) "V") + (test-success "6, being 5 + 1, is VI" equal? roman '(6) + "VI") + (test-success "9, being 10 - 1, is IX" equal? roman '(9) + "IX") + (test-success "20 is two X's" equal? roman '(20) "XX") + (test-success "27 is 10 + 10 + 5 + 1 + 1" equal? roman '(27) + "XXVII") + (test-success "48 is not 50 - 2 but rather 40 + 8" equal? + roman '(48) "XLVIII") + (test-success + "49 is not 40 + 5 + 4 but rather 50 - 10 + 10 - 1" equal? + roman '(49) "XLIX") + (test-success "50 is a single L" equal? roman '(50) "L") + (test-success "59 is 50 + 10 - 1" equal? roman '(59) "LIX") + (test-success "60, being 50 + 10, is LX" equal? roman '(60) + "LX") + (test-success "90, being 100 - 10, is XC" equal? roman '(90) + "XC") + (test-success "93 is 100 - 10 + 1 + 1 + 1" equal? roman + '(93) "XCIII") + (test-success "100 is a single C" equal? roman '(100) "C") + (test-success "141 is 100 + 50 - 10 + 1" equal? roman '(141) + "CXLI") + (test-success "163 is 100 + 50 + 10 + 1 + 1 + 1" equal? + roman '(163) "CLXIII") + (test-success "400, being 500 - 100, is CD" equal? roman + '(400) "CD") + (test-success "402 is 500 - 100 + 2" equal? roman '(402) + "CDII") + (test-success "500 is a single D" equal? roman '(500) "D") + (test-success "575 is 500 + 50 + 10 + 10 + 5" equal? roman + '(575) "DLXXV") + (test-success "900, being 1000 - 100, is CM" equal? roman + '(900) "CM") + (test-success "911 is 1000 - 100 + 10 + 1" equal? roman + '(911) "CMXI") + (test-success "1000 is a single M" equal? roman '(1000) "M") + (test-success "1024 is 1000 + 10 + 10 + 5 - 1" equal? roman + '(1024) "MXXIV") + (test-success "3000 is three M's" equal? roman '(3000) + "MMM"))) + +(run-with-cli "roman-numerals.scm" (list test-cases)) diff --git a/exercises/practice/rotational-cipher/.meta/config.json b/exercises/practice/rotational-cipher/.meta/config.json index 3aaa14ba..60a12889 100644 --- a/exercises/practice/rotational-cipher/.meta/config.json +++ b/exercises/practice/rotational-cipher/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Create an implementation of the rotational cipher, also sometimes called the Caesar cipher.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "rotational-cipher.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Create an implementation of the rotational cipher, also sometimes called the Caesar cipher.", "source": "Wikipedia", "source_url": "https://en.wikipedia.org/wiki/Caesar_cipher" } diff --git a/exercises/practice/rotational-cipher/test-util.ss b/exercises/practice/rotational-cipher/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/rotational-cipher/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/rotational-cipher/test.scm b/exercises/practice/rotational-cipher/test.scm index 14a18f01..493a7bed 100644 --- a/exercises/practice/rotational-cipher/test.scm +++ b/exercises/practice/rotational-cipher/test.scm @@ -1,148 +1,24 @@ -(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 rotate) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "rotate a by 0, same output as input" equal? - rotate '("a" 0) "a")) - (lambda () - (test-success "rotate a by 1" equal? rotate '("a" 1) "b")) - (lambda () - (test-success "rotate a by 26, same output as input" equal? - rotate '("a" 26) "a")) - (lambda () - (test-success "rotate m by 13" equal? rotate '("m" 13) "z")) - (lambda () - (test-success "rotate n by 13 with wrap around alphabet" - equal? rotate '("n" 13) "a")) - (lambda () - (test-success "rotate capital letters" equal? rotate - '("OMG" 5) "TRL")) - (lambda () - (test-success "rotate spaces" equal? rotate '("O M G" 5) - "T R L")) - (lambda () - (test-success "rotate numbers" equal? rotate - '("Testing 1 2 3 testing" 4) "Xiwxmrk 1 2 3 xiwxmrk")) - (lambda () - (test-success "rotate punctuation" equal? rotate - '("Let's eat, Grandma!" 21) "Gzo'n zvo, Bmviyhv!")) - (lambda () - (test-success "rotate all letters" equal? rotate - '("The quick brown fox jumps over the lazy dog." 13) - "Gur dhvpx oebja sbk whzcf bire gur ynml qbt.")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "rotational-cipher.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "rotational-cipher.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "rotate a by 0, same output as input" equal? + rotate '("a" 0) "a") (test-success "rotate a by 1" equal? rotate '("a" 1) "b") + (test-success "rotate a by 26, same output as input" equal? + rotate '("a" 26) "a") + (test-success "rotate m by 13" equal? rotate '("m" 13) "z") + (test-success "rotate n by 13 with wrap around alphabet" + equal? rotate '("n" 13) "a") + (test-success "rotate capital letters" equal? rotate + '("OMG" 5) "TRL") + (test-success "rotate spaces" equal? rotate '("O M G" 5) + "T R L") + (test-success "rotate numbers" equal? rotate + '("Testing 1 2 3 testing" 4) "Xiwxmrk 1 2 3 xiwxmrk") + (test-success "rotate punctuation" equal? rotate + '("Let's eat, Grandma!" 21) "Gzo'n zvo, Bmviyhv!") + (test-success "rotate all letters" equal? rotate + '("The quick brown fox jumps over the lazy dog." 13) + "Gur dhvpx oebja sbk whzcf bire gur ynml qbt."))) + +(run-with-cli "rotational-cipher.scm" (list test-cases)) diff --git a/exercises/practice/scrabble-score/.meta/config.json b/exercises/practice/scrabble-score/.meta/config.json index b7e86130..fbf85455 100644 --- a/exercises/practice/scrabble-score/.meta/config.json +++ b/exercises/practice/scrabble-score/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a word, compute the Scrabble score for that word.", "authors": [ "cyborgsphinx" ], @@ -15,12 +14,14 @@ "scrabble-score.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a word, compute the Scrabble score for that word.", "source": "Inspired by the Extreme Startup game", "source_url": "https://github.com/rchatley/extreme_startup" } diff --git a/exercises/practice/scrabble-score/test-util.ss b/exercises/practice/scrabble-score/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/scrabble-score/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/scrabble-score/test.scm b/exercises/practice/scrabble-score/test.scm index af79f158..bf90f5d9 100644 --- a/exercises/practice/scrabble-score/test.scm +++ b/exercises/practice/scrabble-score/test.scm @@ -1,142 +1,19 @@ -(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 score) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "lowercase letter" = score '("a") 1)) - (lambda () - (test-success "uppercase letter" = score '("A") 1)) - (lambda () - (test-success "valuable letter" = score '("f") 4)) - (lambda () (test-success "short word" = score '("at") 2)) - (lambda () - (test-success "short, valuable word" = score '("zoo") 12)) - (lambda () - (test-success "medium word" = score '("street") 6)) - (lambda () - (test-success "medium, valuable word" = score '("quirky") - 22)) - (lambda () - (test-success "long, mixed-case word" = score - '("OxyphenButazone") 41)) - (lambda () - (test-success "english-like word" = score '("pinata") 8)) - (lambda () (test-success "empty input" = score '("") 0)) - (lambda () - (test-success "entire alphabet available" = score - '("abcdefghijklmnopqrstuvwxyz") 87)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "scrabble-score.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "scrabble-score.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "lowercase letter" = score '("a") 1) (test-success "uppercase letter" = score '("A") 1) + (test-success "valuable letter" = score '("f") 4) + (test-success "short word" = score '("at") 2) + (test-success "short, valuable word" = score '("zoo") 12) + (test-success "medium word" = score '("street") 6) + (test-success "medium, valuable word" = score '("quirky") + 22) + (test-success "long, mixed-case word" = score + '("OxyphenButazone") 41) + (test-success "english-like word" = score '("pinata") 8) + (test-success "empty input" = score '("") 0) + (test-success "entire alphabet available" = score + '("abcdefghijklmnopqrstuvwxyz") 87))) + +(run-with-cli "scrabble-score.scm" (list test-cases)) diff --git a/exercises/practice/sieve/.meta/config.json b/exercises/practice/sieve/.meta/config.json index 4e540824..75e4d938 100644 --- a/exercises/practice/sieve/.meta/config.json +++ b/exercises/practice/sieve/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Use the Sieve of Eratosthenes to find all the primes from 2 up to a given number.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "sieve.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Use the Sieve of Eratosthenes to find all the primes from 2 up to a given number.", "source": "Sieve of Eratosthenes at Wikipedia", "source_url": "http://en.wikipedia.org/wiki/Sieve_of_Eratosthenes" } diff --git a/exercises/practice/sieve/test-util.ss b/exercises/practice/sieve/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/sieve/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/sieve/test.scm b/exercises/practice/sieve/test.scm index 17473c08..7587c14f 100644 --- a/exercises/practice/sieve/test.scm +++ b/exercises/practice/sieve/test.scm @@ -1,154 +1,32 @@ -(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 sieve) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no primes under two" equal? sieve '(1) '())) - (lambda () - (test-success "find first prime" equal? sieve '(2) '(2))) - (lambda () - (test-success "find primes up to 10" equal? sieve '(10) - '(2 3 5 7))) - (lambda () - (test-success "limit is prime" equal? sieve '(13) - '(2 3 5 7 11 13))) - (lambda () - (test-success "find primes up to 1000" equal? sieve '(1000) - '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 - 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 - 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 - 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 - 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 - 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 - 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 - 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 - 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 - 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 - 929 937 941 947 953 967 971 977 983 991 997))) - (lambda () - (test-success "1229 primes below 10000" - (lambda (result n) (= n (length result))) sieve '(10000) - 1229)) - (lambda () - (test-success "9592 primes below 100000" - (lambda (result n) (= n (length result))) sieve '(100000) - 9592)) - (lambda () - (test-success "78498 primes below 1000000" - (lambda (result n) (= n (length result))) sieve '(1000000) - 78498)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "sieve.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "sieve.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "no primes under two" equal? sieve '(1) '()) (test-success "find first prime" equal? sieve '(2) '(2)) + (test-success "find primes up to 10" equal? sieve '(10) + '(2 3 5 7)) + (test-success "limit is prime" equal? sieve '(13) + '(2 3 5 7 11 13)) + (test-success "find primes up to 1000" equal? sieve '(1000) + '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 + 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 + 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 + 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 + 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 + 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 + 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 + 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 + 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 + 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 + 929 937 941 947 953 967 971 977 983 991 997)) + (test-success "1229 primes below 10000" + (lambda (result n) (= n (length result))) sieve '(10000) + 1229) + (test-success "9592 primes below 100000" + (lambda (result n) (= n (length result))) sieve '(100000) + 9592) + (test-success "78498 primes below 1000000" + (lambda (result n) (= n (length result))) sieve '(1000000) + 78498))) + +(run-with-cli "sieve.scm" (list test-cases)) diff --git a/exercises/practice/strain/.meta/config.json b/exercises/practice/strain/.meta/config.json index 6b9e1d9a..056c17f3 100644 --- a/exercises/practice/strain/.meta/config.json +++ b/exercises/practice/strain/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Implement the `keep` and `discard` operation on collections. Given a collection and a predicate on the collection's elements, `keep` returns a new collection containing those elements where the predicate is true, while `discard` returns a new collection containing those elements where the predicate is false.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "strain.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Implement the `keep` and `discard` operation on collections. Given a collection and a predicate on the collection's elements, `keep` returns a new collection containing those elements where the predicate is true, while `discard` returns a new collection containing those elements where the predicate is false.", "source": "Conversation with James Edward Gray II", "source_url": "https://twitter.com/jeg2" } diff --git a/exercises/practice/strain/.meta/example.scm b/exercises/practice/strain/.meta/example.scm index 29aa72d1..71f78479 100644 --- a/exercises/practice/strain/.meta/example.scm +++ b/exercises/practice/strain/.meta/example.scm @@ -6,4 +6,4 @@ [else (keep pred (cdr seq))])) (define (discard pred seq) - (keep (compose not pred) seq)) + (keep (lambda (x) (not (pred x))) seq)) diff --git a/exercises/practice/strain/Makefile b/exercises/practice/strain/Makefile new file mode 100644 index 00000000..ea4c6c16 --- /dev/null +++ b/exercises/practice/strain/Makefile @@ -0,0 +1,17 @@ +solution := + +chez := scheme +guile := guile + +help : + echo 'Run make chez or make guile' + +check-all : chez guile + +chez : + $(chez) --script test.scm $(solution) + +guile : + $(guile) test.scm $(solution) + +.PHONY : help check-all chez guile diff --git a/exercises/practice/strain/test-util.ss b/exercises/practice/strain/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/strain/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/strain/test.scm b/exercises/practice/strain/test.scm index 65e91650..59be0c3c 100644 --- a/exercises/practice/strain/test.scm +++ b/exercises/practice/strain/test.scm @@ -1,162 +1,38 @@ -(import (except (rnrs) current-output-port)) +(load "test-util.ss") -(define test-fields '(input output)) +(define (under-10? n) (< n 10)) -(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 (under-10? n) - (< n 10)) - -(define (starts-with-z? s) - (char=? (string-ref s 0) #\z)) - -(define keep) -(define discard) +(define (starts-with-z? s) (char=? (string-ref s 0) #\z)) (define test-cases - (list - (lambda () - (test-success "empty keep" equal? keep `(,under-10? ()) '())) - (lambda () - (test-success "keep everything" equal? keep - `(,under-10? (0 2 4 6 8)) '(0 2 4 6 8))) - (lambda () - (test-success "keep first last" equal? keep `(,odd? (1 2 3)) '(1 3))) - (lambda () - (test-success "keep nothing" equal? keep `(,even? (1 3 5 7 9)) '())) - (lambda () - (test-success "keep neither first nor last" equal? keep - `(,even? (1 2 3)) '(2))) - (lambda () - (test-success - "keep strings" equal? keep - `(,starts-with-z? ("apple" "zebra" "banana" "zombies" "cherimoya" "zealot")) - '("zebra" "zombies" "zealot"))) - (lambda () - (test-success "empty discard" equal? discard `(,under-10? ()) '())) - (lambda () - (test-success "discard everything" equal? discard - `(,under-10? (1 2 3)) '())) - (lambda () - (test-success "discard first and last" equal? discard - `(,odd? (1 2 3)) '(2))) - (lambda () - (test-success "discard nothing" equal? discard - `(,even? (1 3 5 7 9)) '(1 3 5 7 9))) - (lambda () - (test-success "discard neither first nor last" equal? discard - `(,even? (1 2 3)) '(1 3))) - (lambda () - (test-success - "discard strings" equal? discard - `(,starts-with-z? ("apple" "zebra" "banana" "zombies" "cherimoya" "zealot")) - '("apple" "banana" "cherimoya"))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "strain.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "strain.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "empty keep" equal? keep `(,under-10? ()) + '()) + (test-success "keep everything" equal? keep + `(,under-10? (0 2 4 6 8)) '(0 2 4 6 8)) + (test-success "keep first last" equal? keep `(,odd? (1 2 3)) + '(1 3)) + (test-success "keep nothing" equal? keep + `(,even? (1 3 5 7 9)) '()) + (test-success "keep neither first nor last" equal? keep + `(,even? (1 2 3)) '(2)) + (test-success "keep strings" equal? keep + `(,starts-with-z? + ("apple" "zebra" "banana" "zombies" "cherimoya" "zealot")) + '("zebra" "zombies" "zealot")) + (test-success "empty discard" equal? discard + `(,under-10? ()) '()) + (test-success "discard everything" equal? discard + `(,under-10? (1 2 3)) '()) + (test-success "discard first and last" equal? discard + `(,odd? (1 2 3)) '(2)) + (test-success "discard nothing" equal? discard + `(,even? (1 3 5 7 9)) '(1 3 5 7 9)) + (test-success "discard neither first nor last" equal? + discard `(,even? (1 2 3)) '(1 3)) + (test-success "discard strings" equal? discard + `(,starts-with-z? + ("apple" "zebra" "banana" "zombies" "cherimoya" "zealot")) + '("apple" "banana" "cherimoya")))) + +(run-with-cli "strain.scm" (list test-cases)) diff --git a/exercises/practice/sum-of-multiples/.meta/config.json b/exercises/practice/sum-of-multiples/.meta/config.json index a8c5418e..343eb85d 100644 --- a/exercises/practice/sum-of-multiples/.meta/config.json +++ b/exercises/practice/sum-of-multiples/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a number, find the sum of all the multiples of particular numbers up to but not including that number.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "sum-of-multiples.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a number, find the sum of all the multiples of particular numbers up to but not including that number.", "source": "A variation on Problem 1 at Project Euler", "source_url": "http://projecteuler.net/problem=1" } diff --git a/exercises/practice/sum-of-multiples/.meta/example.scm b/exercises/practice/sum-of-multiples/.meta/example.scm index ae2fe493..405c9602 100644 --- a/exercises/practice/sum-of-multiples/.meta/example.scm +++ b/exercises/practice/sum-of-multiples/.meta/example.scm @@ -1,8 +1,14 @@ -(use-modules (srfi srfi-1)) +(import (rnrs)) + +(define (delete x xs) + (filter (lambda (y) (not (equal? x y))) xs)) + +(define (any f xs) + (fold-left (lambda (r x) (or r (f x))) #f xs)) (define (sum-of-multiples ints limit) (apply + (filter (lambda (n) (any (lambda (i) - (zero? (remainder n i))) - (delete 0 ints))) + (zero? (remainder n i))) + (delete 0 ints))) (cdr (iota limit))))) diff --git a/exercises/practice/sum-of-multiples/test-util.ss b/exercises/practice/sum-of-multiples/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/sum-of-multiples/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/sum-of-multiples/test.scm b/exercises/practice/sum-of-multiples/test.scm index cb999785..6dc61f8c 100644 --- a/exercises/practice/sum-of-multiples/test.scm +++ b/exercises/practice/sum-of-multiples/test.scm @@ -1,169 +1,42 @@ -(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 sum-of-multiples) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no multiples within limit" - equal? sum-of-multiples '((3 5) 1) 0)) - (lambda () - (test-success "one factor has multiples within limit" - equal? sum-of-multiples '((3 5) 4) 3)) - (lambda () - (test-success "more than one multiple within limit" - equal? sum-of-multiples '((3) 7) 9)) - (lambda () - (test-success "more than one factor with multiples within limit" - equal? sum-of-multiples '((3 5) 10) 23)) - (lambda () - (test-success "each multiple is only counted once" - equal? sum-of-multiples '((3 5) 100) 2318)) - (lambda () - (test-success "a much larger limit" - equal? sum-of-multiples '((3 5) 1000) 233168)) - (lambda () - (test-success "three factors" - equal? sum-of-multiples '((7 13 17) 20) 51)) - (lambda () - (test-success "factors not relatively prime" - equal? sum-of-multiples '((4 6) 15) 30)) - (lambda () - (test-success "some pairs of factors relatively prime and some not" - equal? sum-of-multiples '((5 6 8) 150) 4419)) - (lambda () - (test-success "one factor is a multiple of another" - equal? sum-of-multiples '((5 25) 51) 275)) - (lambda () - (test-success "much larger factors" - equal? sum-of-multiples '((43 47) 10000) 2203160)) - (lambda () - (test-success "all numbers are multiples of 1" - equal? sum-of-multiples '((1) 100) 4950)) - (lambda () - (test-success "no factors means an empty sum" - equal? sum-of-multiples '(() 10000) 0)) - (lambda () - (test-success "the only multiple of 0 is 0" - equal? sum-of-multiples '((0) 1) 0)) - (lambda () - (test-success - "the factor 0 does not affect the sum of multiples of other factors" - equal? sum-of-multiples '((3 0) 4) 3)) - (lambda () - (test-success - "solutions using include-exclude must extend to cardinality greater than 3" - equal? sum-of-multiples '((2 3 5 7 11) 10000) 39614537)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "sum-of-multiples.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "sum-of-multiples.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "no multiples within limit" equal? + sum-of-multiples '((3 5) 1) 0) + (test-success "one factor has multiples within limit" equal? + sum-of-multiples '((3 5) 4) 3) + (test-success "more than one multiple within limit" equal? + sum-of-multiples '((3) 7) 9) + (test-success + "more than one factor with multiples within limit" equal? + sum-of-multiples '((3 5) 10) 23) + (test-success "each multiple is only counted once" equal? + sum-of-multiples '((3 5) 100) 2318) + (test-success "a much larger limit" equal? sum-of-multiples + '((3 5) 1000) 233168) + (test-success "three factors" equal? sum-of-multiples + '((7 13 17) 20) 51) + (test-success "factors not relatively prime" equal? + sum-of-multiples '((4 6) 15) 30) + (test-success + "some pairs of factors relatively prime and some not" equal? + sum-of-multiples '((5 6 8) 150) 4419) + (test-success "one factor is a multiple of another" equal? + sum-of-multiples '((5 25) 51) 275) + (test-success "much larger factors" equal? sum-of-multiples + '((43 47) 10000) 2203160) + (test-success "all numbers are multiples of 1" equal? + sum-of-multiples '((1) 100) 4950) + (test-success "no factors means an empty sum" equal? + sum-of-multiples '(() 10000) 0) + (test-success "the only multiple of 0 is 0" equal? + sum-of-multiples '((0) 1) 0) + (test-success + "the factor 0 does not affect the sum of multiples of other factors" + equal? sum-of-multiples '((3 0) 4) 3) + (test-success + "solutions using include-exclude must extend to cardinality greater than 3" + equal? sum-of-multiples '((2 3 5 7 11) 10000) 39614537))) + +(run-with-cli "sum-of-multiples.scm" (list test-cases)) diff --git a/exercises/practice/transpose/.meta/config.json b/exercises/practice/transpose/.meta/config.json index 1d3d0ce7..e257651d 100644 --- a/exercises/practice/transpose/.meta/config.json +++ b/exercises/practice/transpose/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Take input text and output it transposed.", "authors": [ "jitwit" ], @@ -8,12 +7,14 @@ "transpose.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Take input text and output it transposed.", "source": "Reddit r/dailyprogrammer challenge #270 [Easy].", "source_url": "https://www.reddit.com/r/dailyprogrammer/comments/4msu2x/challenge_270_easy_transpose_the_input_text" } diff --git a/exercises/practice/transpose/test-util.ss b/exercises/practice/transpose/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/transpose/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/transpose/test.scm b/exercises/practice/transpose/test.scm index 549e27f5..2c5847cc 100644 --- a/exercises/practice/transpose/test.scm +++ b/exercises/practice/transpose/test.scm @@ -1,193 +1,68 @@ -(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 transpose) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "empty string" equal? transpose '(()) '())) - (lambda () - (test-success "two characters in a row" equal? transpose - '(((65 49))) '((65) (49)))) - (lambda () - (test-success "two characters in a column" equal? transpose - '(((65) (49))) '((65 49)))) - (lambda () - (test-success "simple" equal? transpose - '(((65 66 67) (49 50 51))) '((65 49) (66 50) (67 51)))) - (lambda () - (test-success "single line" equal? transpose - '(((83 105 110 103 108 101 32 108 105 110 101 46))) - '((83) (105) (110) (103) (108) (101) (32) (108) (105) (110) - (101) (46)))) - (lambda () - (test-success "first line longer than second line" equal? transpose - '(((84 104 101 32 102 111 117 114 116 104 32 108 105 110 101 - 46) - (84 104 101 32 102 105 102 116 104 32 108 105 110 101 46 - 32))) - '((84 84) (104 104) (101 101) (32 32) (102 102) (111 105) (117 102) - (114 116) (116 104) (104 32) (32 108) (108 105) (105 110) - (110 101) (101 46) (46 32)))) - (lambda () - (test-success "second line longer than first line" equal? transpose - '(((84 104 101 32 102 105 114 115 116 32 108 105 110 101 46 + `((test-success "empty string" equal? transpose '(()) '()) + (test-success "two characters in a row" equal? transpose + '(((65 49))) '((65) (49))) + (test-success "two characters in a column" equal? transpose + '(((65) (49))) '((65 49))) + (test-success "simple" equal? transpose + '(((65 66 67) (49 50 51))) '((65 49) (66 50) (67 51))) + (test-success "single line" equal? transpose + '(((83 105 110 103 108 101 32 108 105 110 101 46))) + '((83) (105) (110) (103) (108) (101) (32) (108) (105) (110) + (101) (46))) + (test-success "first line longer than second line" equal? transpose + '(((84 104 101 32 102 111 117 114 116 104 32 108 105 110 101 + 46) + (84 104 101 32 102 105 102 116 104 32 108 105 110 101 46 + 32))) + '((84 84) (104 104) (101 101) (32 32) (102 102) (111 105) (117 102) + (114 116) (116 104) (104 32) (32 108) (108 105) (105 110) + (110 101) (101 46) (46 32))) + (test-success "second line longer than first line" equal? transpose + '(((84 104 101 32 102 105 114 115 116 32 108 105 110 101 46 + 32) + (84 104 101 32 115 101 99 111 110 100 32 108 105 110 101 + 46))) + '((84 84) (104 104) (101 101) (32 32) (102 115) (105 101) (114 99) + (115 111) (116 110) (32 100) (108 32) (105 108) (110 105) + (101 110) (46 101) (32 46))) + (test-success "mixed line length" equal? transpose + '(((84 104 101 32 108 111 110 103 101 115 116 32 108 105 110 + 101 46) + (65 32 108 111 110 103 32 108 105 110 101 46 32 32 32 32 32) + (65 32 108 111 110 103 101 114 32 108 105 110 101 46 32 32 32) - (84 104 101 32 115 101 99 111 110 100 32 108 105 110 101 - 46))) - '((84 84) (104 104) (101 101) (32 32) (102 115) (105 101) (114 99) - (115 111) (116 110) (32 100) (108 32) (105 108) (110 105) - (101 110) (46 101) (32 46)))) - (lambda () - (test-success "mixed line length" equal? transpose - '(((84 104 101 32 108 111 110 103 101 115 116 32 108 105 110 - 101 46) - (65 32 108 111 110 103 32 108 105 110 101 46 32 32 32 32 32) - (65 32 108 111 110 103 101 114 32 108 105 110 101 46 32 32 - 32) - (65 32 108 105 110 101 46 32 32 32 32 32 32 32 32 32 32))) - '((84 65 65 65) (104 32 32 32) (101 108 108 108) (32 111 111 105) - (108 110 110 110) (111 103 103 101) (110 32 101 46) - (103 108 114 32) (101 105 32 32) (115 110 108 32) - (116 101 105 32) (32 46 110 32) (108 32 101 32) - (105 32 46 32) (110 32 32 32) (101 32 32 32) - (46 32 32 32)))) - (lambda () - (test-success "square" equal? transpose - '(((72 69 65 82 84) - (69 77 66 69 82) - (65 66 85 83 69) - (82 69 83 73 78) - (84 82 69 78 68))) - '((72 69 65 82 84) + (65 32 108 105 110 101 46 32 32 32 32 32 32 32 32 32 32))) + '((84 65 65 65) (104 32 32 32) (101 108 108 108) (32 111 111 105) + (108 110 110 110) (111 103 103 101) (110 32 101 46) + (103 108 114 32) (101 105 32 32) (115 110 108 32) + (116 101 105 32) (32 46 110 32) (108 32 101 32) + (105 32 46 32) (110 32 32 32) (101 32 32 32) (46 32 32 32))) + (test-success "square" equal? transpose + '(((72 69 65 82 84) (69 77 66 69 82) (65 66 85 83 69) (82 69 83 73 78) - (84 82 69 78 68)))) - (lambda () - (test-success "rectangle" equal? transpose - '(((70 82 65 67 84 85 82 69) - (79 85 84 76 73 78 69 68) - (66 76 79 79 77 73 78 71) - (83 69 80 84 69 84 84 69))) - '((70 79 66 83) (82 85 76 69) (65 84 79 80) (67 76 79 84) (84 73 77 69) - (85 78 73 84) (82 69 78 84) (69 68 71 69)))) - (lambda () - (test-success "triangle" equal? transpose - '(((84 32 32 32 32 32) (69 69 32 32 32 32) (65 65 65 32 32 32) (83 83 83 83 32 32) - (69 69 69 69 69 32) (82 82 82 82 82 82))) - '((84 69 65 83 69 82) (32 69 65 83 69 82) (32 32 65 83 69 82) (32 32 32 83 69 82) - (32 32 32 32 69 82) (32 32 32 32 32 82)))))) - -(define (test . query) - (apply run-test-suite test-cases query)) + (84 82 69 78 68))) + '((72 69 65 82 84) + (69 77 66 69 82) + (65 66 85 83 69) + (82 69 83 73 78) + (84 82 69 78 68))) + (test-success "rectangle" equal? transpose + '(((70 82 65 67 84 85 82 69) + (79 85 84 76 73 78 69 68) + (66 76 79 79 77 73 78 71) + (83 69 80 84 69 84 84 69))) + '((70 79 66 83) (82 85 76 69) (65 84 79 80) (67 76 79 84) (84 73 77 69) + (85 78 73 84) (82 69 78 84) (69 68 71 69))) + (test-success "triangle" equal? transpose + '(((84 32 32 32 32 32) (69 69 32 32 32 32) (65 65 65 32 32 32) (83 83 83 83 32 32) + (69 69 69 69 69 32) (82 82 82 82 82 82))) + '((84 69 65 83 69 82) (32 69 65 83 69 82) (32 32 65 83 69 82) (32 32 32 83 69 82) + (32 32 32 32 69 82) (32 32 32 32 32 82))))) -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "transpose.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "transpose.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) +(run-with-cli "transpose.scm" (list test-cases)) diff --git a/exercises/practice/triangle/.meta/config.json b/exercises/practice/triangle/.meta/config.json index d445ade8..64cb70f0 100644 --- a/exercises/practice/triangle/.meta/config.json +++ b/exercises/practice/triangle/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Determine if a triangle is equilateral, isosceles, or scalene.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "triangle.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Determine if a triangle is equilateral, isosceles, or scalene.", "source": "The Ruby Koans triangle project, parts 1 & 2", "source_url": "http://rubykoans.com" } diff --git a/exercises/practice/triangle/.meta/example.scm b/exercises/practice/triangle/.meta/example.scm index 65b87323..516001dc 100644 --- a/exercises/practice/triangle/.meta/example.scm +++ b/exercises/practice/triangle/.meta/example.scm @@ -1,10 +1,38 @@ -(use-modules (srfi srfi-1)) +(import (rnrs)) + +(define (any f xs) + (fold-left (lambda (r x) (or r (f x))) #f xs)) + +(define (every f xs) + (fold-left (lambda (r x) (and r (f x))) #t xs)) + +(define (string-any f s) + (any f (string->list s))) + +(define (string-every f s) + (every f (string->list s))) + +(define (nub xs) + (fold-left (lambda (ys x) + (if (any (lambda (y) (equal? x y)) ys) ys + (cons x ys))) + '() xs)) + +(define (impl-safe-sort f xs) + (call/cc + (lambda (k) + (with-exception-handler + (lambda (e) + ;; Uh-oh, we're using Guile! + (k (sort xs f))) + (lambda () + (sort f xs)))))) (define (triangle a b c) - (let ([xs (sort (list a b c) >)]) + (let ([xs (impl-safe-sort > (list a b c))]) (if (>= (car xs) (apply + (cdr xs))) (error "Invalid triangle") - (case (length (delete-duplicates xs)) + (case (length (nub xs)) [(1) 'equilateral] [(2) 'isosceles] [else 'scalene])))) diff --git a/exercises/practice/triangle/test-util.ss b/exercises/practice/triangle/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/triangle/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/triangle/test.scm b/exercises/practice/triangle/test.scm index 803511c8..c0bbb9ab 100644 --- a/exercises/practice/triangle/test.scm +++ b/exercises/practice/triangle/test.scm @@ -1,145 +1,28 @@ -(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 triangle) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "equilateral: 2 2 2" equal? triangle '(2 2 2) 'equilateral)) - (lambda () - (test-success "equilateral: 10 10 10" equal? triangle '(10 10 10) 'equilateral)) - (lambda () - (test-success "isosceles: 3 4 4" equal? triangle '(3 4 4) 'isosceles)) - (lambda () - (test-success "isosceles: 4 3 4" equal? triangle '(4 3 4) 'isosceles)) - (lambda () - (test-success "isosceles: 4 4 3" equal? triangle '(4 4 3) 'isosceles)) - (lambda () - (test-success "isosceles: 10 10 2" equal? triangle '(10 10 2) 'isosceles)) - (lambda () - (test-success "scalene: 3 4 5" equal? triangle '(3 4 5) 'scalene)) - (lambda () - (test-success "scalene: 10 11 12" equal? triangle '(10 11 12) 'scalene)) - (lambda () - (test-success "scalene: 5 4 2" equal? triangle '(5 4 2) 'scalene)) - (lambda () - (test-error "invalid: 0 0 0" triangle '(0 0 0))) - (lambda () - (test-error "invalid: 3 4 -5" triangle '(3 4 -5))) - (lambda () - (test-error "invalid: 1 1 3" triangle '(1 1 3))) - (lambda () - (test-error "invalid: 2 4 2" triangle '(2 4 2))))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "triangle.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "triangle.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "equilateral: 2 2 2" equal? triangle + '(2 2 2) 'equilateral) + (test-success "equilateral: 10 10 10" equal? triangle + '(10 10 10) 'equilateral) + (test-success "isosceles: 3 4 4" equal? triangle '(3 4 4) + 'isosceles) + (test-success "isosceles: 4 3 4" equal? triangle '(4 3 4) + 'isosceles) + (test-success "isosceles: 4 4 3" equal? triangle '(4 4 3) + 'isosceles) + (test-success "isosceles: 10 10 2" equal? triangle + '(10 10 2) 'isosceles) + (test-success "scalene: 3 4 5" equal? triangle '(3 4 5) + 'scalene) + (test-success "scalene: 10 11 12" equal? triangle + '(10 11 12) 'scalene) + (test-success "scalene: 5 4 2" equal? triangle '(5 4 2) + 'scalene) + (test-error "invalid: 0 0 0" triangle '(0 0 0)) + (test-error "invalid: 3 4 -5" triangle '(3 4 -5)) + (test-error "invalid: 1 1 3" triangle '(1 1 3)) + (test-error "invalid: 2 4 2" triangle '(2 4 2)))) + +(run-with-cli "triangle.scm" (list test-cases)) diff --git a/exercises/practice/trinary/.meta/config.json b/exercises/practice/trinary/.meta/config.json index 2546a6c4..0307891a 100644 --- a/exercises/practice/trinary/.meta/config.json +++ b/exercises/practice/trinary/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Convert a trinary number, represented as a string (e.g. '102012'), to its decimal equivalent using first principles.", "authors": [ "tongkiat" ], @@ -8,12 +7,14 @@ "trinary.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Convert a trinary number, represented as a string (e.g. '102012'), to its decimal equivalent using first principles.", "source": "All of Computer Science", "source_url": "http://www.wolframalpha.com/input/?i=binary&a=*C.binary-_*MathWorld-" } diff --git a/exercises/practice/trinary/.meta/example.scm b/exercises/practice/trinary/.meta/example.scm index e2ca7593..08f6b1b6 100644 --- a/exercises/practice/trinary/.meta/example.scm +++ b/exercises/practice/trinary/.meta/example.scm @@ -1,10 +1,27 @@ -(use-modules (ice-9 regex)) +(import (rnrs)) + +(define (any f xs) + (fold-left (lambda (r x) (or r (f x))) #f xs)) + +(define (every f xs) + (fold-left (lambda (r x) (and r (f x))) #t xs)) + +(define (string-any f s) + (any f (string->list s))) + +(define (string-every f s) + (every f (string->list s))) (define (to-decimal s) - (if (string-match "[^0-2]" s) - 0 - (apply + - (map (lambda (d e) - (* (- (char->integer d) (char->integer #\0)) (expt 3 e))) - (reverse (string->list s)) - (iota (string-length s)))))) + (call/cc + (lambda (fail) + (unless (string-every (lambda (c) + (any (lambda (d) (char=? c d)) + '(#\0 #\1 #\2))) + s) + (fail 0)) + (apply + + (map (lambda (d e) + (* (- (char->integer d) (char->integer #\0)) (expt 3 e))) + (reverse (string->list s)) + (iota (string-length s))))))) diff --git a/exercises/practice/trinary/test-util.ss b/exercises/practice/trinary/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/trinary/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/trinary/test.scm b/exercises/practice/trinary/test.scm index 86214a3d..b15bf49e 100644 --- a/exercises/practice/trinary/test.scm +++ b/exercises/practice/trinary/test.scm @@ -1,149 +1,30 @@ -(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 trinary) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success - "returns the decimal representation of the input trinary value" equal? - to-decimal '("1") 1)) - (lambda () - (test-success "trinary 2 is decimal 2" equal? to-decimal '("2") 2)) - (lambda () - (test-success "trinary 10 is decimal 3" equal? to-decimal '("10") 3)) - (lambda () - (test-success "trinary 11 is decimal 4" equal? to-decimal '("11") 4)) - (lambda () - (test-success "trinary 100 is decimal 9" equal? to-decimal '("100") 9)) - (lambda () - (test-success "trinary 112 is decimal 14" equal? to-decimal '("112") 14)) - (lambda () - (test-success "trinary 222 is decimal 26" equal? to-decimal '("222") 26)) - (lambda () - (test-success - "trinary 1122000120 is decimal 32091" equal? - to-decimal '("1122000120") 32091)) - (lambda () - (test-success - "invalid trinary digits returns 0" equal? to-decimal '("1234") 0)) - (lambda () - (test-success - "invalid word as input returns 0" equal? to-decimal '("carrot") 0)) - (lambda () - (test-success - "invalid numbers with letters as input returns 0" equal? - to-decimal '("0a1b2c") 0)))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "trinary.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "trinary.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success + "returns the decimal representation of the input trinary value" + equal? to-decimal '("1") 1) + (test-success "trinary 2 is decimal 2" equal? to-decimal + '("2") 2) + (test-success "trinary 10 is decimal 3" equal? to-decimal + '("10") 3) + (test-success "trinary 11 is decimal 4" equal? to-decimal + '("11") 4) + (test-success "trinary 100 is decimal 9" equal? to-decimal + '("100") 9) + (test-success "trinary 112 is decimal 14" equal? to-decimal + '("112") 14) + (test-success "trinary 222 is decimal 26" equal? to-decimal + '("222") 26) + (test-success "trinary 1122000120 is decimal 32091" equal? + to-decimal '("1122000120") 32091) + (test-success "invalid trinary digits returns 0" equal? + to-decimal '("1234") 0) + (test-success "invalid word as input returns 0" equal? + to-decimal '("carrot") 0) + (test-success + "invalid numbers with letters as input returns 0" equal? + to-decimal '("0a1b2c") 0))) + +(run-with-cli "trinary.scm" (list test-cases)) diff --git a/exercises/practice/two-fer/.meta/config.json b/exercises/practice/two-fer/.meta/config.json index dcb0d7b3..c30a7373 100644 --- a/exercises/practice/two-fer/.meta/config.json +++ b/exercises/practice/two-fer/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Create a sentence of the form \"One for X, one for me.\"", "authors": [ "herwinw" ], @@ -13,11 +12,13 @@ "two-fer.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Create a sentence of the form \"One for X, one for me.\"", "source_url": "https://github.com/exercism/problem-specifications/issues/757" } diff --git a/exercises/practice/two-fer/test-util.ss b/exercises/practice/two-fer/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/two-fer/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/two-fer/test.scm b/exercises/practice/two-fer/test.scm index c654353c..ed6462e1 100644 --- a/exercises/practice/two-fer/test.scm +++ b/exercises/practice/two-fer/test.scm @@ -1,128 +1,12 @@ -(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 two-fer) +(load "test-util.ss") (define test-cases - (list - (lambda () - (test-success "no name given" equal? two-fer '() - "One for you, one for me.")) - (lambda () - (test-success "a name given" equal? two-fer '("Alice") - "One for Alice, one for me.")) - (lambda () - (test-success "another name given" equal? two-fer '("Bob") - "One for Bob, one for me.")))) - -(define (test . query) - (apply run-test-suite test-cases query)) - -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "two-fer.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "two-fer.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) + `((test-success "no name given" equal? two-fer '() + "One for you, one for me.") + (test-success "a name given" equal? two-fer '("Alice") + "One for Alice, one for me.") + (test-success "another name given" equal? two-fer '("Bob") + "One for Bob, one for me."))) + +(run-with-cli "two-fer.scm" (list test-cases)) diff --git a/exercises/practice/word-count/.meta/config.json b/exercises/practice/word-count/.meta/config.json index 65303c90..cab7e60f 100644 --- a/exercises/practice/word-count/.meta/config.json +++ b/exercises/practice/word-count/.meta/config.json @@ -1,5 +1,4 @@ { - "blurb": "Given a phrase, count the occurrences of each word in that phrase.", "authors": [ "wwest4" ], @@ -13,11 +12,13 @@ "word-count.scm" ], "test": [ - "test.scm" + "test.scm", + "test-util.ss" ], "example": [ ".meta/example.scm" ] }, + "blurb": "Given a phrase, count the occurrences of each word in that phrase.", "source": "This is a classic toy problem, but we were reminded of it by seeing it in the Go Tour." } diff --git a/exercises/practice/word-count/test-util.ss b/exercises/practice/word-count/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/exercises/practice/word-count/test-util.ss @@ -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 'actual)]))) diff --git a/exercises/practice/word-count/test.scm b/exercises/practice/word-count/test.scm index 9c2c3a23..1003e8e5 100644 --- a/exercises/practice/word-count/test.scm +++ b/exercises/practice/word-count/test.scm @@ -1,201 +1,70 @@ -(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))) +(load "test-util.ss") (define (matches? result expected) (let ([get-count (if (hashtable? result) - (lambda (word) - (hashtable-ref result word 0)) - (lambda (word) - (cond - [(assoc word result) => cdr] - [else 0])))]) + (lambda (word) (hashtable-ref result word 0)) + (lambda (word) + (cond [(assoc word result) => cdr] [else 0])))]) (and (= (length expected) - (if (hashtable? result) (hashtable-size result) (length result))) + (if (hashtable? result) + (hashtable-size result) + (length result))) (fold-left (lambda (count-agrees w.c) - (and count-agrees - (= (cdr w.c) (get-count (car w.c))))) + (and count-agrees (= (cdr w.c) (get-count (car w.c))))) #t expected)))) -(define word-count) - (define test-cases - (list - (lambda () - (test-success "count one word" matches? - word-count '("word") '(("word" . 1)))) - (lambda () - (test-success "count one of each word" matches? - word-count '("one of each") - '(("one" . 1) ("of" . 1) ("each" . 1)))) - (lambda () - (test-success "multiple occurrences of a word" matches? - word-count '("one fish two fish red fish blue fish") - '(("one" . 1) - ("fish" . 4) - ("two" . 1) - ("red" . 1) - ("blue" . 1)))) - (lambda () - (test-success "handles cramped lists" matches? - word-count '("one,two,three") - '(("one" . 1) ("two" . 1) ("three" . 1)))) - (lambda () - (test-success "handles expanded lists" matches? - word-count '("one,\ntwo,\nthree") - '(("one" . 1) ("two" . 1) ("three" . 1)))) - (lambda () - (test-success "ignore punctuation" matches? - word-count '("car: carpet as java: javascript!!&@$%^&") - '(("car" . 1) - ("carpet" . 1) - ("as" . 1) - ("java" . 1) - ("javascript" . 1)))) - (lambda () - (test-success "include numbers" matches? - word-count '("testing, 1, 2 testing") - '(("testing" . 2) ("1" . 1) ("2" . 1)))) - (lambda () - (test-success "normalize case" matches? - word-count '("go Go GO Stop stop") - '(("go" . 3) ("stop" . 2)))) - (lambda () - (test-success "with apostrophes" matches? - word-count '("First: don't laugh. Then: don't cry.") - '(("first" . 1) - ("don't" . 2) - ("laugh" . 1) - ("then" . 1) - ("cry" . 1)))) - (lambda () - (test-success "with quotations" matches? - word-count '("Joe can't tell between 'large' and large.") - '(("joe" . 1) ("can't" . 1) ("tell" . 1) ("between" . 1) - ("large" . 2) ("and" . 1)))) - (lambda () - (test-success "substrings from the beginning" matches? - word-count '("Joe can't tell between app, apple and a.") - '(("joe" . 1) ("can't" . 1) ("tell" . 1) ("between" . 1) - ("app" . 1) ("apple" . 1) ("and" . 1) ("a" . 1)))) - (lambda () - (test-success "multiple spaces not detected as a word" matches? - word-count '(" multiple whitespaces") - '(("multiple" . 1) ("whitespaces" . 1)))) - (lambda () - (test-success "alternating word separators not detected as a word" matches? - word-count '(",\n,one,\n ,two \n 'three'") - '(("one" . 1) ("two" . 1) ("three" . 1)))))) - -(define (test . query) - (apply run-test-suite test-cases query)) + `((test-success "count one word" matches? word-count + '("word") '(("word" . 1))) + (test-success "count one of each word" matches? word-count + '("one of each") '(("one" . 1) ("of" . 1) ("each" . 1))) + (test-success "multiple occurrences of a word" matches? word-count + '("one fish two fish red fish blue fish") + '(("one" . 1) + ("fish" . 4) + ("two" . 1) + ("red" . 1) + ("blue" . 1))) + (test-success "handles cramped lists" matches? word-count + '("one,two,three") '(("one" . 1) ("two" . 1) ("three" . 1))) + (test-success "handles expanded lists" matches? word-count + '("one,\ntwo,\nthree") + '(("one" . 1) ("two" . 1) ("three" . 1))) + (test-success "ignore punctuation" matches? word-count + '("car: carpet as java: javascript!!&@$%^&") + '(("car" . 1) + ("carpet" . 1) + ("as" . 1) + ("java" . 1) + ("javascript" . 1))) + (test-success "include numbers" matches? word-count + '("testing, 1, 2 testing") + '(("testing" . 2) ("1" . 1) ("2" . 1))) + (test-success "normalize case" matches? word-count + '("go Go GO Stop stop") '(("go" . 3) ("stop" . 2))) + (test-success "with apostrophes" matches? word-count + '("First: don't laugh. Then: don't cry.") + '(("first" . 1) + ("don't" . 2) + ("laugh" . 1) + ("then" . 1) + ("cry" . 1))) + (test-success "with quotations" matches? word-count + '("Joe can't tell between 'large' and large.") + '(("joe" . 1) ("can't" . 1) ("tell" . 1) ("between" . 1) + ("large" . 2) ("and" . 1))) + (test-success "substrings from the beginning" matches? word-count + '("Joe can't tell between app, apple and a.") + '(("joe" . 1) ("can't" . 1) ("tell" . 1) ("between" . 1) + ("app" . 1) ("apple" . 1) ("and" . 1) ("a" . 1))) + (test-success "multiple spaces not detected as a word" matches? + word-count '(" multiple whitespaces") + '(("multiple" . 1) ("whitespaces" . 1))) + (test-success "alternating word separators not detected as a word" + matches? word-count '(",\n,one,\n ,two \n 'three'") + '(("one" . 1) ("two" . 1) ("three" . 1))))) -(let ([args (command-line)]) - (cond - [(null? (cdr args)) - (load "word-count.scm") - (test 'input 'output)] - [(string=? (cadr args) "--docker") - (load "word-count.scm") - (run-docker test-cases)] - [else (load (cadr args)) (test 'input 'output)])) +(run-with-cli "word-count.scm" (list test-cases)) diff --git a/input/test-util.ss b/input/test-util.ss new file mode 100644 index 00000000..599bbe5a --- /dev/null +++ b/input/test-util.ss @@ -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 'actual)]))) diff --git a/script/ci.ss b/script/ci.ss index 8ea69f6e..912b6934 100644 --- a/script/ci.ss +++ b/script/ci.ss @@ -4,6 +4,8 @@ (system "touch ci")) (define (run-tests exercism) + (display (format "running tests for ~a" exercism)) + (newline) (let* ((dir (format "exercises/practice/~a" exercism)) (result (system (format "cp input/skeleton-makefile ~a/Makefile && cd ~a && make check-all solution=.meta/example.scm" @@ -11,3 +13,12 @@ dir)))) (unless (zero? result) (error 'run-ci "failed test" exercism)))) + +;; Run tests for all directory expect for exercises named in except. +(define (run-all-tests . except) + (let ((blacklist + (map (lambda (x) (if (symbol? x) (symbol->string x) x)) except))) + (for-each run-tests + (filter + (lambda (x) (andmap (lambda (y) (not (equal? x y))) blacklist)) + (directory-list "exercises/practice/")))))