From de418111bbc56fb0aa625d2ef0019c8e43e058e5 Mon Sep 17 00:00:00 2001
From: Correl Roush <correl@gmail.com>
Date: Fri, 25 Apr 2014 13:02:16 -0400
Subject: [PATCH] Error monad

---
 src/calrissian.app.src               |  4 +++-
 src/error-monad.lfe                  | 22 +++++++++++++++++
 test/unit/unit-error-monad-tests.lfe | 36 ++++++++++++++++++++++++++++
 3 files changed, 61 insertions(+), 1 deletion(-)
 create mode 100644 src/error-monad.lfe
 create mode 100644 test/unit/unit-error-monad-tests.lfe

diff --git a/src/calrissian.app.src b/src/calrissian.app.src
index 6172c31..72f11ed 100644
--- a/src/calrissian.app.src
+++ b/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.
diff --git a/src/error-monad.lfe b/src/error-monad.lfe
new file mode 100644
index 0000000..f37e0bd
--- /dev/null
+++ b/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))
diff --git a/test/unit/unit-error-monad-tests.lfe b/test/unit/unit-error-monad-tests.lfe
new file mode 100644
index 0000000..8f2982d
--- /dev/null
+++ b/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))))