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