From f923b68374861496fa4fe38ac4cc50f4fc3fa318 Mon Sep 17 00:00:00 2001
From: Correl Roush <correl@gmail.com>
Date: Fri, 25 Apr 2014 01:06:19 -0400
Subject: [PATCH] Add sequence, more generic monad tests

---
 include/monad-tests.lfe              | 34 ++++++++++++++++++++++++++++
 include/monads.lfe                   | 12 ++++++++++
 test/unit/unit-maybe-monad-tests.lfe |  6 +----
 3 files changed, 47 insertions(+), 5 deletions(-)

diff --git a/include/monad-tests.lfe b/include/monad-tests.lfe
index e3f1321..8aa03b2 100644
--- a/include/monad-tests.lfe
+++ b/include/monad-tests.lfe
@@ -1,3 +1,32 @@
+(defmacro test-monad-functions (monad)
+  `(progn
+     (deftest monad->>=
+       (is-equal (return ,monad 2)
+                 (>>= ,monad
+                      (return ,monad 1)
+                      (lambda (n) (return ,monad (+ 1 n))))))
+     (deftest monad->>
+       (is-equal (return ,monad 1)
+                 (>> ,monad
+                     (return ,monad 5)
+                     (return ,monad 1))))
+     (deftest monad-do
+       (is-equal (return ,monad 'ok)
+                 (do ,monad
+                     (return ,monad 'ignored)
+                     (return ,monad 'ok))))
+     (deftest monad-do-binding
+       (is-equal (return ,monad 9)
+                 (do ,monad
+                     (a <- (return ,monad 3))
+                     (return ,monad (* a a)))))
+     (deftest monad-sequence
+       (is-equal (return ,monad (list 1 2 3))
+                 (sequence ,monad (list (return ,monad 1)
+                                        (return ,monad 2)
+                                        (return ,monad 3)))))
+     ))
+
 (defmacro test-monad-laws (monad)
   `(progn
      (deftest monad-left-identity
@@ -42,3 +71,8 @@
                      (do ,monad (y <- (funcall f x))
                        (funcall g y))))))
      ))
+
+(defmacro test-monad (monad)
+  `(progn
+     (test-monad-functions ,monad)
+     (test-monad-laws ,monad)))
diff --git a/include/monads.lfe b/include/monads.lfe
index 15736e2..b3f3c15 100644
--- a/include/monads.lfe
+++ b/include/monads.lfe
@@ -11,3 +11,15 @@
 
 (defmacro return (monad expr)
   `(: ,monad return ,expr))
+
+(defmacro sequence (monad list)
+  `(: lists foldr
+     (lambda (m acc) (mcons ,monad m acc))
+     (return ,monad [])
+     ,list))
+
+(defmacro mcons (monad m mlist)
+  `(do ,monad
+       (x <- ,m)
+     (rest <- ,mlist)
+     (return ,monad (cons x rest))))
diff --git a/test/unit/unit-maybe-monad-tests.lfe b/test/unit/unit-maybe-monad-tests.lfe
index 7f5ac96..f9209fa 100644
--- a/test/unit/unit-maybe-monad-tests.lfe
+++ b/test/unit/unit-maybe-monad-tests.lfe
@@ -9,7 +9,7 @@
 (include-lib "include/monads.lfe")
 (include-lib "include/monad-tests.lfe")
 
-(test-monad-laws maybe-monad)
+(test-monad maybe-monad)
 
 (deftest bind-short-circuit-value
   (is-equal 'nothing
@@ -36,10 +36,6 @@
                                  minc
                                  minc)))))
 
-(deftest >>
-  (is-equal #(just 3)
-            (>> maybe-monad #(just 5) #(just 3))))
-
 (deftest do-bindings
   (is-equal #(just 3)
             (do maybe-monad