;;; SPDX-License-Identifier: CC0-1.0
;;;
;;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>

(define-module (myra-test-utils)
  #:use-module ((srfi srfi-26) #:select(cut))
  #:use-module ((srfi srfi-34) #:select (guard raise))
  #:use-module ((srfi srfi-35) #:select (condition-type? condition-has-type?))
  #:use-module ((srfi srfi-64) #:prefix srfi-64:)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:use-module ((ice-9 match) #:select (match))
  #:use-module ((system repl error-handling)
                #:select (call-with-error-handling))
  #:re-export ((srfi-64:test-group . test-group))
  #:export (%interactive-debugging

            test-assert
            test-eq
            test-eqv
            test-equal
            test-approximate
            test-error

            call-with-fixtures
            with-fixtures
            test-group-with-fixtures))

(define %interactive-debugging
  (make-parameter #f))

(define (wrap-call thunk)
  (if (%interactive-debugging)
      (call-with-error-handling thunk)
      (thunk)))

(define-syntax-rule (wrap test-expr)
  (wrap-call (lambda () test-expr)))

(define-syntax-rule (test-assert stuff ... test-expr)
  (srfi-64:test-assert stuff ... (wrap test-expr)))

(define-syntax-rule (test-eq stuff ... test-expr)
  (srfi-64:test-eq stuff ... (wrap test-expr)))

(define-syntax-rule (test-eqv stuff ... test-expr)
  (srfi-64:test-eqv stuff ... (wrap test-expr)))

(define-syntax-rule (test-equal stuff ... test-expr)
  (srfi-64:test-equal stuff ... (wrap test-expr)))

(define-syntax-rule (test-approximate stuff ... test-expr error)
  (srfi-64:test-approximate stuff ... (wrap test-expr) error))

(define %exception-object-indicator
  (gensym))

(define (except-error error-type thunk)
  (match (let/ec escape
           (guard (unexpected-ex (#t
                                  (escape unexpected-ex)))
             (wrap-call (lambda ()
                          (guard (ex
                                  ((or (and (condition-type? error-type)
                                            (condition-has-type? ex error-type))
                                       (and (procedure? error-type)
                                            (error-type ex))
                                       (eq? error-type #t))
                                   (escape (list %exception-object-indicator
                                                 ex))))
                            (const (thunk)))))))
    (((? (cut eq? %exception-object-indicator <>)) ex)
     (raise ex))
    (result
     result)))

(define-syntax test-error
  (syntax-rules ()
    ((test-error test-expr)
     (test-error #t test-expr))
    ((test-error stuff ... error-type test-expr)
     (srfi-64:test-error stuff ... #t
                         (except-error error-type (lambda () test-expr))))))

(define (call-with-fixtures fixtures thunk)
  (match fixtures
    (()
     (thunk))
    ((fixture . rest)
     (fixture (cut call-with-fixtures rest thunk)))))

(define-syntax-rule (with-fixtures fixtures body ...)
  (call-with-fixtures fixtures (lambda () body ...)))

(define-syntax-rule (test-group-with-fixtures name fixtures body ...)
  (with-fixtures fixtures (srfi-64:test-group name body ...)))