Implement simple testing module for e2e tests

e2e/testing.scm

@@ -0,0 +1,64 @@
+(define-module (e2e testing)
+  #:export (assert define-test run-tests))
+
+(use-modules
+ (sxml simple)
+ (srfi srfi-1))
+
+(define *tests* (make-fluid '()))
+
+(define (assert condition . args)
+  (unless condition
+	(let ((msg (if (null? args) "Assertion failed" (car args))))
+	  (raise-exception `(assertion-failed . ,msg)))))
+
+(define-syntax-rule (define-test name body ...)
+  (fluid-set!
+   *tests*
+   (append (fluid-ref *tests*)
+		   (list (cons 'name (lambda () body ...))))))
+
+(define (fail-handler ex)
+  (if (and (pair? ex) (eq? 'assertion-failed (car ex)))
+	  (cons 'fail (cdr ex))
+	  (cons 'error (format #f "~a" ex))))
+
+(define (run-test test)
+  (cons (car test)
+		(with-exception-handler fail-handler
+		  (lambda ()
+			((cdr test))
+			'pass)
+		  #:unwind? #t)))
+
+(define (fail? result)
+  (and (pair? (cdr result))
+	   (eq? 'fail (cadr result))))
+
+(define (error? result)
+  (and (pair? (cdr result))
+	   (eq? 'error (cadr result))))
+
+(define (test-junit-report result)
+  `(testcase
+	(@ (name ,(symbol->string (car result))))
+	,@(cond
+	   ((fail? result) `((failure (@ (message ,(cddr result))))))
+	   ((error? result) `((error (@ (message ,(cddr result))))))
+	   (#t '()))))
+
+(define (junit-report results)
+  (let ((count (length results))
+		(fails (length (filter fail? results)))
+		(errors (length (filter error? results))))
+	`(testsuites
+	  (testsuite
+	   (@ (name "wipforth e2e")
+		  (tests ,count)
+		  (failures ,fails)
+		  (errors ,errors))
+	   ,@(map test-junit-report results)))))
+
+(define (run-tests)
+  (let ((results (map run-test (fluid-ref *tests*))))
+	(sxml->xml (junit-report results))))