Merge pull request #386 from pdcawley/refactor/testing

Eliminate double eval from xtmtest and xtmtest-compile
digego · May 18, 2020 · 43a18ee · 43a18ee
2 parents 711567e + a3e2325
commit 43a18ee
Show file tree

Hide file tree

Showing 16 changed files with 490 additions and 437 deletions.
diff --git a/libs/core/test.xtm b/libs/core/test.xtm
@@ -83,33 +83,38 @@
                      (equal? exp-res 'compile-should-fail))
                 (xtmtest-update-test-result func-sym 'correct ',call #f #f)
                 (xtmtest-update-test-result func-sym 'no-compile ',call #f #f))
-            (eval ,form (interaction-environment))
+            (eval ',form (interaction-environment))
             (catch (xtmtest-update-test-result func-sym 'compile ',call #f #f)
-                   (let ((result (eval ,call (interaction-environment))))
+                   (let ((result (eval ',call (interaction-environment))))
                      (if (or (not exp-res) (equal? exp-res result))
                          (xtmtest-update-test-result func-sym 'correct ',call exp-res result)
                          (xtmtest-update-test-result func-sym 'incorrect ',call exp-res result)))))))
 
 (define-macro (xtmtest-compile form)
-  `(let ((func-sym (quote ,(cadadr form))))
+  `(let ((func-sym (quote ,(cadr form))))
      (print-with-colors 'cyan 'default #t (print "xtmtest "))
      (print-with-colors 'black 'cyan #t (print "" func-sym ""))
      (println)
      (catch (xtmtest-update-test-result func-sym 'no-compile 'compile-only #f #f)
-            (eval ,form (interaction-environment))
+            (eval ',form (interaction-environment))
             (xtmtest-update-test-result func-sym 'correct 'compile-only #t #t))))
 
-(define-macro (xtmtest-result call expected-result)
-  `(let ((evaluation-environment (current-environment))
-         (func-sym (quote ,(car call))))
-     (print-with-colors 'cyan 'default #t (print "xtmtest "))
-     (print-with-colors 'black 'cyan #t (print "" func-sym ""))
-     (println)
-     (catch (xtmtest-update-test-result func-sym ',call 'compile #f #f)
-            (let ((result (eval ',call evaluation-environment)))
-              (if (equal? ,expected-result result)
-                  (xtmtest-update-test-result func-sym 'correct ',call ,expected-result result)
-                  (xtmtest-update-test-result func-sym 'incorrect ',call ,expected-result result))))))
+(define (xtmtest-result-body call expected-result extra)
+  (let ((prefix (if (null? extra) "" (format "~a: " (car extra)))))
+    `(let ((evaluation-environment (current-environment))
+           (test-name (format "~a ~a" ,prefix ',(if (pair? call) (car call) call))))
+       (print-with-colors 'cyan 'default #t (print "xtmtest "))
+       (print-with-colors 'black 'cyan #t (print "" test-name ))
+       (println)
+       (catch (xtmtest-update-test-result test-name ',call 'compile #f #f)
+              (let ((result (eval ',call evaluation-environment)))
+                (if (equal? ,expected-result result)
+                    (xtmtest-update-test-result ',prefix 'correct ',call ,expected-result result)
+                    (xtmtest-update-test-result ',prefix 'incorrect ',call ,expected-result result))))))  )
+
+(define-macro (xtmtest-result call expected-result . extra)
+  (xtmtest-result-body call expected-result extra))
+
 
 (define xtmtest-print-results
   (lambda ()
@@ -179,3 +184,28 @@
                            0)))
           ;; if not quitting, set the timeout back
           (sys:set-default-timeout timeout)))))
+
+;;; xmttest-with-fixture
+
+(define (xtmtest-with-fixture-body name fixture tests)
+  `(let ((fixture-environment ((lambda () (current-environment)))))
+     (let ((suite-name ',name))
+       (print-with-colors 'cyan 'default #t (print "xtmtest "))
+       (print-with-colors 'black 'cyan #t (print "" suite-name))
+       (println)
+       (eval `(begin
+                (define-macro (is? call expected-result . args)
+                  (xtmtest-result-body call
+                                       expected-result
+                                       (list (if (not (null? args))
+                                                 (format "~a.~a" ',suite-name (car args))
+                                                 (format "~a.is?" ',suite-name))))))
+             fixture-environment)
+       (catch (xtmtest-update-test-result suite-name 'no-compile ',fixture #f #f)
+              (eval ',fixture fixture-environment)
+              (eval '(begin ,@tests) fixture-environment)))))
+
+
+(define-macro (xtmtest-with-fixture name fixture . tests)
+  (xtmtest-with-fixture-body name fixture tests))
+
diff --git a/tests/all-core.xtm b/tests/all-core.xtm
@@ -10,6 +10,6 @@
 
 ;;; Code:
 
-(xtmtest-run-tests (append '("tests/core/system.xtm" "tests/core/adt.xtm" "tests/core/math.xtm" "tests/core/std.xtm" "tests/core/xtlang.xtm" "tests/core/constraints.xtm" "tests/core/expr_problem.xtm" "tests/core/algebraic_data_types.xtm")
+(xtmtest-run-tests (append '("tests/core/system.xtm" "tests/core/test.xtm" "tests/core/adt.xtm" "tests/core/math.xtm" "tests/core/std.xtm" "tests/core/xtlang.xtm" "tests/core/constraints.xtm" "tests/core/expr_problem.xtm" "tests/core/algebraic_data_types.xtm")
                            (unix-or-Windows '("tests/core/generics.xtm") '()))
                    #t #t)