Error monad

src/calrissian.app.src

@@ -11,7 +11,9 @@
   {modules,
    [
     'monad',
-    'maybe-monad'
+    'maybe-monad',
+    'identity-monad',
+    'error-monad'
    ]},
 
   %% All of the registered names the application uses. This can be ignored.

src/error-monad.lfe

@@ -0,0 +1,22 @@
+(defmodule error-monad
+  (behaviour monad)
+  (export (>>= 2)
+          (return 1)
+          (fail 1)))
+
+(defun >>=
+  (((tuple 'error reason) f)
+   (tuple 'error reason))
+  (((tuple 'ok value) f)
+   (funcall f value))
+  (('ok f)
+   (funcall f 'ok)))
+
+(defun return
+  (('ok)
+   'ok)
+  ((x)
+   (tuple 'ok x)))
+
+(defun fail (reason)
+  (tuple 'error reason))

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

@@ -0,0 +1,36 @@
+(defmodule unit-error-monad-tests
+  (export all)
+  (import
+    (from lfeunit-util
+      (check-failed-assert 2)
+      (check-wrong-assert-exception 2))))
+
+(include-lib "deps/lfeunit/include/lfeunit-macros.lfe")
+(include-lib "include/monads.lfe")
+(include-lib "include/monad-tests.lfe")
+
+(test-monad error-monad)
+
+(deftest return-ok
+  (is-equal 'ok
+            (return error-monad 'ok)))
+
+(deftest return-value
+  (is-equal #(ok 123)
+            (return error-monad 123)))
+
+(deftest fail-with-reason
+  (is-equal #(error reason)
+            (fail error-monad 'reason)))
+
+(deftest fail-short-circuits-value
+  (is-equal (fail error-monad 'something-bad)
+            (>> error-monad
+                (fail error-monad 'something-bad)
+                (return error-monad 123))))
+
+(deftest fail-short-circuits-error
+  (is-equal #(error something-bad)
+            (>> error-monad
+                (fail error-monad 'something-bad)
+                (throw 'error))))