Generalized monad interface

include/monads.lfe

@@ -0,0 +1,13 @@
+(defmacro do args
+  (let ((monad (car args))
+        (statements (cdr args)))
+    (monad:do-transform monad statements)))
+
+(defmacro >>= (monad m f)
+  `(: ,monad >>= ,m ,f))
+
+(defmacro >> (monad m1 m2)
+  `(: ,monad >>= ,m1 (lambda (_) ,m2)))
+
+(defmacro return (monad expr)
+  `(: ,monad return ,expr))

src/maybe-monad.lfe

@@ -0,0 +1,14 @@
+(defmodule maybe-monad
+  (behaviour monad)
+  (export (>>= 2)
+          (return 1)
+          (fail 1)))
+
+(defun >>=
+  (('nothing f)
+   'nothing)
+  (((tuple 'just x) f)
+   (funcall f x)))
+
+(defun return (x) (tuple 'just x))
+(defun fail (_) 'nothing)

src/maybe.lfe

@@ -1,25 +0,0 @@
-(defmodule maybe
-  (export all))
-
-(defun my-adder (x y)
-  (+ x (+ y 1)))
-
-(defun >>=
-  (('nothing f)
-   'nothing)
-  (((tuple 'just x) f)
-   (funcall f x)))
-
-(defun >> (a b)
-  (>>= a (lambda (_) b)))
-
-(defun return (x) (tuple 'just x))
-(defun fail (_) 'nothing)
-
-(defun do-statement
-  (((cons h '())) h)
-  (((cons (list f '<- m) t)) (list ': 'maybe '>>=
-                                   m
-                                   (list 'lambda (list f) (do-statement t))))
-  (((cons h t)) (list ': 'maybe '>> h (do-statement t)))
-  )

src/monad.lfe

@@ -0,0 +1,17 @@
+(defmodule monad
+  (export (behaviour-info 1)
+          (do-transform 2)))
+
+(defun behaviour-info
+  (('callbacks) (list #(>>= 2)
+                      #(return 1)
+                      #(fail 1)))
+  ((_) 'undefined))
+
+(defun do-transform
+  ((monad (cons h '())) h)
+  ((monad (cons (list f '<- m) t)) (list ': monad '>>=
+                                   m
+                                   (list 'lambda (list f) (do-transform monad t))))
+  ((monad (cons h t)) (list '>> monad h (do-transform monad t)))
+  )

test/unit/unit-maybe-monad-tests.lfe

@@ -1,4 +1,4 @@
-(defmodule unit-maybe-tests
+(defmodule unit-maybe-monad-tests
   (export all)
   (import
     (from lfeunit-util
@@ -6,27 +6,27 @@
       (check-wrong-assert-exception 2))))
 
 (include-lib "deps/lfeunit/include/lfeunit-macros.lfe")
-(include-lib "include/maybe.lfe")
+(include-lib "include/monads.lfe")
 
 (deftest bind-nothing
   (is-equal 'nothing
-            (maybe:>>= 'nothing
+            (>>= maybe-monad 'nothing
                        (lambda (x) (+ 5 x)))))
 
 (deftest bind-nothing-error
   (is-equal 'nothing
-            (maybe:>>= 'nothing
+            (>>= maybe-monad 'nothing
                        (lambda (_) (error 'bad-func)))))
 
 (deftest bind-five
   (is-equal 10
-            (maybe:>>= (tuple 'just 5)
+            (>>= maybe-monad (tuple 'just 5)
                        (lambda (x) (+ 5 x)))))
 
 (deftest bind-fold
   (is-equal #(just 3)
-            (let ((minc (lambda (x) (maybe:return (+ 1 x))))
+            (let ((minc (lambda (x) (return maybe-monad (+ 1 x))))
-                  (bind (lambda (f m) (maybe:>>= m f))))
+                  (bind (lambda (f m) (>>= maybe-monad m f))))
               (lists:foldr bind
                            #(just 0)
                            (list minc
@@ -35,15 +35,17 @@
 
 (deftest >>
   (is-equal #(just 3)
-            (maybe:>> #(just 5) #(just 3))))
+            (>> maybe-monad #(just 5) #(just 3))))
 
 (deftest do-bindings
   (is-equal #(just 3)
-            (do (a <- #(just 1))
+            (do maybe-monad
-                (b <- #(just 2))
+                (a <- #(just 1))
-              (maybe:return (+ a b)))))
+              (b <- #(just 2))
+              (return maybe-monad (+ a b)))))
 
 (deftest do-nobindings
   (is-equal #(just 3)
-            (do #(just 5)
+            (do maybe-monad
-                #(just 3))))
+                #(just 5)
+              #(just 3))))