From e5a0de5dda02556bcbac112ec551f97f103a8486 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 20 Dec 2016 20:00:29 -0400
Subject: - lux/test can now handle thrown exceptions better. - lux/test
 supports specifying seeds to run tests on.

---
 stdlib/source/lux/host.lux |  3 +--
 stdlib/source/lux/test.lux | 53 +++++++++++++++++++++++++++++-----------------
 2 files changed, 35 insertions(+), 21 deletions(-)

(limited to 'stdlib')

diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux
index 22bd0f292..69148bbd2 100644
--- a/stdlib/source/lux/host.lux
+++ b/stdlib/source/lux/host.lux
@@ -366,7 +366,6 @@
                 (lambda [idx]
                   (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"]
                              [(_lux_proc ["jvm" "aaload"] [trace idx])]))))
-        reverse
         (text;join-with "\n")
         )))
 
@@ -374,7 +373,7 @@
   (-> (host java.lang.Throwable) StackTrace)
   (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t]))
 
-(def: #export (throwable->text t)
+(def: #hidden (throwable->text t)
   (All [a] (-> (host java.lang.Throwable) (Either Text a)))
   (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t])
                   "\n"
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index f08e91336..46bdb22f8 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -102,15 +102,18 @@
           (repeat' seed' (n.dec times) random-test))
         ))))
 
-(def: #export (repeat times random-test)
-  (-> Nat (R;Random Test) Test)
-  (repeat' (int-to-nat (io;run (System.currentTimeMillis [])))
-           times
+(def: #export (repeat ?seed times random-test)
+  (-> (Maybe Nat) Nat (R;Random Test) Test)
+  (repeat' (default (int-to-nat (io;run (System.currentTimeMillis [])))
+             ?seed)
+           (case ?seed
+             #;None times
+             (#;Some _) +1)
            random-test))
 
 ## [Syntax]
 (type: Property-Test
-  {#seed (Maybe (Either Nat Ident))
+  {#seed (Maybe Nat)
    #bindings (List [AST AST])
    #body AST})
 
@@ -118,23 +121,37 @@
   (#Property Property-Test)
   (#Simple AST))
 
-(def: propery-test^
+(def: seed^
+  (Syntax Nat)
+  (do s;Monad<Syntax>
+    [_ (s;tag! ["" "seed"])]
+    s;nat))
+
+(def: property-test^
   (Syntax Property-Test)
   ($_ s;seq
-      (s;opt (s;alt s;nat
-                    s;symbol))
+      (s;opt seed^)
       (s;tuple (s;some (s;seq s;any s;any)))
       s;any))
 
 (def: test^
   (Syntax Test-Kind)
-  (s;alt propery-test^
+  (s;alt property-test^
          s;any))
 
 (def: (pair-to-list [x y])
   (All [a] (-> [a a] (List a)))
   (list x y))
 
+(def: #hidden (try-body lazy-body)
+  (-> (IO Test) Test)
+  (case (host;try (io;run lazy-body))
+    (#;Right output)
+    output
+
+    (#;Left error)
+    (assert error false)))
+
 (syntax: #export (test: description [body test^])
   {#;doc (doc "Macro for definint tests."
               (test: "lux/pipe exports"
@@ -151,20 +168,18 @@
                      )))}
   (let [body (case body
                (#Property seed bindings body)
-               (let [seed' (case seed
+               (let [=seed (case seed
                              #;None
-                             (' +100)
-
-                             (#;Some (#;Left value))
-                             (ast;nat value)
-
-                             (#;Some (#;Right var))
-                             (ast;symbol var))
+                             (` #;None)
+                             
+                             (#;Some value)
+                             (` (#;Some (~ (ast;nat value)))))
                      bindings' (|> bindings (List/map pair-to-list) List/join)]
-                 (` (repeat (~ seed')
+                 (` (repeat (~ =seed)
+                            +100
                             (do R;Monad<Random>
                               [(~@ bindings')]
-                              ((~' wrap) (~ body))))))
+                              ((~' wrap) (;;try-body (io;io (~ body))))))))
                
                (#Simple body)
                body)]
-- 
cgit v1.2.3