(module test-shim
    ((define-test-suite suite-nesting suites) (define-test-case current-case) test-equal test-eqv test-failure run-suites!)

(import scheme (only (chicken base) error fluid-let alist-ref alist-update!) (only (chicken string) ->string) test)

;; Minimal shim version of the foof-loop test library using the test egg as a backend.

;; Should it be time to do a proper port, the complete original
;; Scheme48/MIT Scheme testing library is available at:
;; https://mumble.net/~campbell/darcs/trc-testing/

;; <suite> : #(symbolic-nested-name description cases-list subsuites)
(define suite-nesting '())            ; ((name . ((sub-name1 . ...) (sub-name2 . ...)))
(define suites '())                   ; ((name . <suite>))
(define current-case #f)

(define-syntax define-test-suite
  (syntax-rules ()
    ((_ symbolic-name description forms ...)
     (let* ((n 'symbolic-name)
            (tail-name (if (pair? n) (car n) n))
            (nested-name (if (pair? n) (reverse n) (list n)))
            (suite (vector nested-name (->string 'description) '()))
            (subsuites (let lp ((name (cdr nested-name))
                                (nesting (alist-ref (car nested-name) suite-nesting eq? '())))
                         (if (null? name)
                             nesting
                             (let ((sub-nesting (lp (cdr name) (alist-ref (car name) nesting eq? '()))))
                               (alist-update! (car name) sub-nesting nesting eq?))))))

       (set! suite-nesting (alist-update! (car nested-name) subsuites suite-nesting))
       (set! suites (alist-update! tail-name suite suites))))))


(define-syntax define-test-case
  (syntax-rules ()
    ((_ symbolic-tail-name description () forms ...)
     (let ((suite (alist-ref 'symbolic-tail-name suites eq?)))
       (if suite
           (vector-set! suite 2 (cons (lambda ()
                                        (fluid-let ((current-case (->string 'description)))
                                          forms ...))
                                      (vector-ref suite 2)))
           (error "test case definition for unknown suite" 'symbolic-tail-name))))))


(define-syntax test-equal
  (syntax-rules ()
    ((_ expected actual)
     (test current-case expected actual))))

(define-syntax test-eqv
  (syntax-rules ()
    ((_ expected actual)
     (test current-case expected actual))))

(define test-failure error)


(define (run-suites!)
  (let lp ((nesting suite-nesting))
    (for-each (lambda (name&sub-suites)
                (let* ((name (car name&sub-suites))
                       (sub-suites (cdr name&sub-suites))
                       (suite (alist-ref name suites)))
                  (test-group (vector-ref suite 1)
                    (for-each (lambda (case) (case)) (vector-ref suite 2))
                    (lp (reverse sub-suites)))))
              nesting))
  (test-exit))
)