From 567c28e71716cb709a49dec8d1c60be9ad879f80 Mon Sep 17 00:00:00 2001
From: Wojtek Kosior <koszko@koszko.org>
Date: Tue, 5 Dec 2023 23:13:36 +0100
Subject: Initial commit.

---
 src/guile/myra-test-utils.scm | 95 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 95 insertions(+)
 create mode 100644 src/guile/myra-test-utils.scm

(limited to 'src/guile/myra-test-utils.scm')

diff --git a/src/guile/myra-test-utils.scm b/src/guile/myra-test-utils.scm
new file mode 100644
index 0000000..4342539
--- /dev/null
+++ b/src/guile/myra-test-utils.scm
@@ -0,0 +1,95 @@
+;;; 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 ...)))
-- 
cgit v1.2.3