;;; SPDX-License-Identifier: CC0-1.0
;;;
;;; Copyright (C) 2023, 2025 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))
  #:export (%interactive-debugging

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

            test-group

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

(define %interactive-debugging
  (make-parameter (not (not (getenv "MYRA_INTERACTIVE_DEBUGGING")))))

(define %stop-on-exception
  (make-parameter (not (not (getenv "MYRA_STOP_ON_EXCEPTION")))))

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

(define (*wrap-test thunk)
  (if (%stop-on-exception)
      (thunk)
      (false-if-exception (thunk))))

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

(define-syntax-rule (wrap-test test)
  (*wrap-test (lambda () test)))

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

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

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

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

(define-syntax-rule (test-approximate stuff ... test-expr error)
  (wrap-test (srfi-64:test-approximate stuff ... (wrap-expr 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-expr (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-syntax-rule (test-group stuff ...)
  (wrap-test (srfi-64:test-group stuff ...)))

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