From c3ff87dfd675cfc47a3067a422fb0fe2bdebd35d Mon Sep 17 00:00:00 2001 From: Peter Kofler Date: Thu, 14 Feb 2019 15:40:21 +0100 Subject: [PATCH] Split R5RS compliant assert out of whole assert. --- assert-r5rs-test.scm | 61 ++++++++++++ assert-r5rs.scm | 218 +++++++++++++++++++++++++++++++++++++++++++ assert.scm | 213 +----------------------------------------- 3 files changed, 281 insertions(+), 211 deletions(-) create mode 100644 assert-r5rs-test.scm create mode 100644 assert-r5rs.scm diff --git a/assert-r5rs-test.scm b/assert-r5rs-test.scm new file mode 100644 index 0000000..a267399 --- /dev/null +++ b/assert-r5rs-test.scm @@ -0,0 +1,61 @@ +(include "assert-r5rs.scm") + +(test-case "(check) should not fail on #t condition" + (lambda () + (check "should not fail" #t))) + +(test-case "(assert=) equals number" + (assert= 1 1)) + +(test-case "(assert-string=) equals string" + (assert-string= "abc" "abc")) + +(test-case "(assert-inexact=) equals number" + (assert-inexact= 1. 1.1 0.11)) + +(test-case "(assert-list=)" + (assert-list= number->string + = + (list 1 2) + (list 1 2))) + +(test-case "(assert-list=) recursive" + (assert-list= number->string + = + (list 1 (list 2 3)) + (list 1 (list 2 3)))) + +(test-case "(assert-list=) with strings" + (assert-list= values + string=? + (list "a") + (list "a")) + (assert-string-list= (list "a") + (list "a"))) + +(test-case "(assert-true)" + (assert-true #t)) + +(test-case "(assert-false)" + (assert-false #f)) + +(test-case "(assert-null)" + (assert-null '())) + +(test-case "(assert-not-null)" + (assert-not-null (list 1))) + +(test-case "(assert-all) allows several assertions" + (assert-all + (assert-true #t) + (assert-true #t))) + +(test-case "(test-case) allows several assertions" + (assert-true #t) + (assert-true #t)) + +(ignored-test-case "(ignored-test-case) is ignored, else it would fail" + (assert-true #f)) + +(test-case "(useless-test-case)" + (lambda () #f)) diff --git a/assert-r5rs.scm b/assert-r5rs.scm new file mode 100644 index 0000000..07df6be --- /dev/null +++ b/assert-r5rs.scm @@ -0,0 +1,218 @@ +;;; +;;; Unit test framework for Scheme R5RS. +;;; Copyright (c) 2015, Peter Kofler, http://www.code-cop.org/ +;;; BSD licensed. +;;; +;;; Non R5RS used functions +;;; * error from SRFI 23, available in Gambit, Chicken. +;;; + +;; SchemeUnit from http://c2.com/cgi/wiki?SchemeUnit +;; @formatter:align_list_of_strings:False + +(define (fail msg) + (error (-make-assertion-error msg))) + +(define (check msg condition) + (if (not condition) + (fail msg) + -success-marker)) + +;; colours + +(include "ansi.scm") + +(define (-in-white s) + (ansi-string-with-color ansi-white s)) + +(define (-in-green s) + (ansi-string-with-color ansi-green s)) + +(define (-in-yellow s) + (ansi-string-with-color ansi-yellow s)) + +(define (-in-red s) + (ansi-string-with-color ansi-red s)) + +;; extensions + +(define (make-check msg condition) + "All high level assertions are lazy to be grouped in test cases." + (lambda () + (check msg condition))) + +(define (-make-assertion-error msg) + (-in-red (string-append "AssertionError" ": " msg))) + +(define -success-marker + (list 'success)) + +(define (-make-string-message prefix to-string expected actual) + (-make-message prefix + (to-string expected) + (to-string actual))) + +(define (-make-message prefix expected actual) + (string-append prefix "expected:<" expected "> but was:<" actual ">")) + +(define (assert-equal to-string eq-op expected actual) + (make-check (-make-string-message "" to-string expected actual) + (eq-op expected actual))) + +(define (assert= expected actual) + (assert-equal number->string = expected actual)) + +(define (assert-string= expected actual) + (assert-equal values string=? expected actual)) + +(define (assert-char= expected actual) + (assert-equal string char=? expected actual)) + +;; private or library function +(define (-interval-inside? center radius x) + (<= (abs (- center x)) + radius)) + +;; private - library function +(define (-interval->string center radius) + (string-append "[" + (number->string (- center radius)) + "-" + (number->string (+ center radius)) + "]")) + +(define (assert-inexact= expected actual delta) + (make-check (-make-message "in range " + (-interval->string expected delta) + (number->string actual)) + (-interval-inside? expected delta actual))) + +(define (assert-list= to-string eq-op expected-list actual-list) + (define (item i) + (string-append (number->string i) ". item ")) + (define (check-list-element i expected actual) + (let* ((expected-l (length expected)) + (actual-l (length actual)) + (no-more? (< expected-l actual-l)) + (has-more? (> expected-l actual-l)) + (both-null? (and (null? expected) (null? actual)))) + (cond (both-null? -success-marker) + (no-more? (fail (-make-message (item (+ i expected-l)) + "no more elements" + "more elements"))) + (has-more? (fail (-make-message (item (+ i actual-l)) + "more elements" + "no more elements"))) + (else (check-element i expected actual))))) + (define (check-element i expected actual) + (let* ((expected-element (car expected)) + (actual-element (car actual)) + (sublist? (pair? expected-element)) + (no-sublist? (pair? actual-element)) + (both-pair? (and sublist? no-sublist?))) + (cond (both-pair? (append ; dummy chaining + (check-list-element (+ (* i 10) 1) + expected-element + actual-element) + (check-list-element (+ i 1) + (cdr expected) + (cdr actual)))) + (sublist? (fail (-make-message (item i) + "a sublist" + "no sublist"))) + (no-sublist? (fail (-make-message (item i) + "no sublist" + "a sublist"))) + (else (append ; dummy chaining + (check-numbered i expected-element actual-element) + (check-list-element (+ i 1) + (cdr expected) + (cdr actual))))))) + (define (check-numbered i expected actual) + (check (-make-message (item i) + (to-string expected) + (to-string actual)) + (eq-op expected actual))) + (lambda () + (check-list-element 1 expected-list actual-list))) + +(define (assert-string-list= expected-list actual-list) + (assert-list= values string=? expected-list actual-list)) + +(define (assert-number-list= expected-list actual-list) + (assert-list= number->string = expected-list actual-list)) + +;; private or library function +(define (-boolean->string b) + (if b "true" "false")) + +(define (assert-true actual) + (make-check (-make-string-message "" -boolean->string #t #f) + actual)) + +(define (assert-predicate predicate value) + (assert-true (predicate value))) + +(define assert-is? assert-predicate) + +(define (assert-not-predicate predicate value) + (assert-false (predicate value))) + +(define assert-not-is? assert-not-predicate) + +(define (assert-false actual) + (make-check (-make-string-message "" -boolean->string #f #t) + (not actual))) + +(define (assert-null actual) + (make-check (-make-message "" "null" "not null") + (null? actual))) + +(define (assert-not-null actual) + (make-check (-make-message "" "not null" "null") + (not (null? actual)))) + +(define (assert-all . assertions) + (lambda () + (let ((results (map -test-case-assert assertions))) + (if (zero? (apply + results)) + 0 + -success-marker)))) + +(define (-test-case-name name) + (display (-in-white name)) + (display " ")) + +(define (-test-case-success) + (display (-in-green " OK")) + (newline)) + +(define (-test-case-assert assert) + (let ((result (assert))) + (display ".") + (if (and (list? result) + (not (null? result)) + (eq? (car result) + (car -success-marker))) + 1 + 0))) + +(define (test-case name . assertions) + (-test-case-name name) + (let* ((results (map -test-case-assert assertions)) + (count (apply + results))) + (if (zero? count) + (-test-case-useless) + (-test-case-success)))) + +(define (-test-case-useless) + (display (-in-yellow " USELESS")) + (newline)) + +(define (-test-case-ignored) + (display (-in-yellow " IGNORED")) + (newline)) + +(define (ignored-test-case name . assertions) + (-test-case-name name) + (-test-case-ignored)) diff --git a/assert.scm b/assert.scm index ada68fb..c61e126 100644 --- a/assert.scm +++ b/assert.scm @@ -1,177 +1,9 @@ ;;; -;;; Unit test framework for Scheme R5RS. +;;; Unit test framework for Scheme R5RS, Gambit extension. ;;; Copyright (c) 2015, Peter Kofler, http://www.code-cop.org/ ;;; BSD licensed. ;;; -;;; Non R5RS used functions -;;; * error from SRFI 23/Gambit -;;; * with-exception-catcher, error-exception?, error-exception-message from Gambit -;;; - -;; SchemeUnit from http://c2.com/cgi/wiki?SchemeUnit -;; @formatter:align_list_of_strings:False - -(define (fail msg) - (error (-make-assertion-error msg))) - -(define (check msg condition) - (if (not condition) - (fail msg) - -success-marker)) - -;; colours - -(include "ansi.scm") - -(define (-in-white s) - (ansi-string-with-color ansi-white s)) - -(define (-in-green s) - (ansi-string-with-color ansi-green s)) - -(define (-in-yellow s) - (ansi-string-with-color ansi-yellow s)) - -(define (-in-red s) - (ansi-string-with-color ansi-red s)) - -;; extensions - -(define (make-check msg condition) - "All high level assertions are lazy to be grouped in test cases." - (lambda () - (check msg condition))) - -(define (-make-assertion-error msg) - (-in-red (string-append "AssertionError" ": " msg))) - -(define -success-marker - (list 'success)) - -(define (-make-string-message prefix to-string expected actual) - (-make-message prefix - (to-string expected) - (to-string actual))) - -(define (-make-message prefix expected actual) - (string-append prefix "expected:<" expected "> but was:<" actual ">")) - -(define (assert-equal to-string eq-op expected actual) - (make-check (-make-string-message "" to-string expected actual) - (eq-op expected actual))) - -(define (assert= expected actual) - (assert-equal number->string = expected actual)) - -(define (assert-string= expected actual) - (assert-equal values string=? expected actual)) - -(define (assert-char= expected actual) - (assert-equal string char=? expected actual)) - -;; private or library function -(define (-interval-inside? center radius x) - (<= (abs (- center x)) - radius)) - -;; private - library function -(define (-interval->string center radius) - (string-append "[" - (number->string (- center radius)) - "-" - (number->string (+ center radius)) - "]")) - -(define (assert-inexact= expected actual delta) - (make-check (-make-message "in range " - (-interval->string expected delta) - (number->string actual)) - (-interval-inside? expected delta actual))) - -(define (assert-list= to-string eq-op expected-list actual-list) - (define (item i) - (string-append (number->string i) ". item ")) - (define (check-list-element i expected actual) - (let* ((expected-l (length expected)) - (actual-l (length actual)) - (no-more? (< expected-l actual-l)) - (has-more? (> expected-l actual-l)) - (both-null? (and (null? expected) (null? actual)))) - (cond (both-null? -success-marker) - (no-more? (fail (-make-message (item (+ i expected-l)) - "no more elements" - "more elements"))) - (has-more? (fail (-make-message (item (+ i actual-l)) - "more elements" - "no more elements"))) - (else (check-element i expected actual))))) - (define (check-element i expected actual) - (let* ((expected-element (car expected)) - (actual-element (car actual)) - (sublist? (pair? expected-element)) - (no-sublist? (pair? actual-element)) - (both-pair? (and sublist? no-sublist?))) - (cond (both-pair? (append ; dummy chaining - (check-list-element (+ (* i 10) 1) - expected-element - actual-element) - (check-list-element (+ i 1) - (cdr expected) - (cdr actual)))) - (sublist? (fail (-make-message (item i) - "a sublist" - "no sublist"))) - (no-sublist? (fail (-make-message (item i) - "no sublist" - "a sublist"))) - (else (append ; dummy chaining - (check-numbered i expected-element actual-element) - (check-list-element (+ i 1) - (cdr expected) - (cdr actual))))))) - (define (check-numbered i expected actual) - (check (-make-message (item i) - (to-string expected) - (to-string actual)) - (eq-op expected actual))) - (lambda () - (check-list-element 1 expected-list actual-list))) - -(define (assert-string-list= expected-list actual-list) - (assert-list= values string=? expected-list actual-list)) - -(define (assert-number-list= expected-list actual-list) - (assert-list= number->string = expected-list actual-list)) - -;; private or library function -(define (-boolean->string b) - (if b "true" "false")) - -(define (assert-true actual) - (make-check (-make-string-message "" -boolean->string #t #f) - actual)) - -(define (assert-predicate predicate value) - (assert-true (predicate value))) - -(define assert-is? assert-predicate) - -(define (assert-not-predicate predicate value) - (assert-false (predicate value))) - -(define assert-not-is? assert-not-predicate) - -(define (assert-false actual) - (make-check (-make-string-message "" -boolean->string #f #t) - (not actual))) - -(define (assert-null actual) - (make-check (-make-message "" "null" "not null") - (null? actual))) - -(define (assert-not-null actual) - (make-check (-make-message "" "not null" "null") - (not (null? actual)))) +(include "assert-r5rs.scm") (define (-error->string ex) (cond ((symbol? ex) (symbol->string ex)) @@ -199,47 +31,6 @@ (lambda () (-run-with-exception-handler ex-handler ex-body))) -(define (assert-all . assertions) - (lambda () - (let ((results (map -test-case-assert assertions))) - (if (zero? (apply + results)) - 0 - -success-marker)))) - -(define (-test-case-name name) - (display (-in-white name)) - (display " ")) - -(define (-test-case-success) - (display (-in-green " OK")) - (newline)) - -(define (-test-case-assert assert) - (let ((result (assert))) - (display ".") - (if (and (list? result) - (not (null? result)) - (eq? (car result) - (car -success-marker))) - 1 - 0))) - -(define (test-case name . assertions) - (-test-case-name name) - (let* ((results (map -test-case-assert assertions)) - (count (apply + results))) - (if (zero? count) - (-test-case-useless) - (-test-case-success)))) - -(define (-test-case-useless) - (display (-in-yellow " USELESS")) - (newline)) - -(define (-test-case-ignored) - (display (-in-yellow " IGNORED")) - (newline)) - (define-macro (ignored-test-case name . assertions) `(begin (-test-case-name ,name)