(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))))