1 files changed, 58 insertions, 0 deletions
diff --git a/stdlib/source/test/lux/abstract/monad.lux b/stdlib/source/test/lux/abstract/monad.lux
new file mode 100644
index 000000000..4382a260d
--- /dev/null
+++ b/stdlib/source/test/lux/abstract/monad.lux
@@ -0,0 +1,58 @@
+(.module:
+  [lux #*
+   [data
+    [text
+     format]]
+   ["." function]
+   [math
+    ["r" random]]
+   ["_" test (#+ Test)]]
+  {1
+   ["." / (#+ Monad do)]}
+  [//
+   [functor (#+ Injection Comparison)]])
+
+(def: (left-identity injection comparison (^open "_;."))
+  (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
+  (do r.monad
+    [sample r.nat
+     morphism (:: @ map (function (_ diff)
+                          (|>> (n/+ diff) _;wrap))
+                  r.nat)]
+    (_.test "Left identity."
+            ((comparison n/=)
+             (|> (injection sample) (_;map morphism) _;join)
+             (morphism sample)))))
+
+(def: (right-identity injection comparison (^open "_;."))
+  (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
+  (do r.monad
+    [sample r.nat]
+    (_.test "Right identity."
+            ((comparison n/=)
+             (|> (injection sample) (_;map _;wrap) _;join)
+             (injection sample)))))
+
+(def: (associativity injection comparison (^open "_;."))
+  (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
+  (do r.monad
+    [sample r.nat
+     increase (:: @ map (function (_ diff)
+                          (|>> (n/+ diff) _;wrap))
+                  r.nat)
+     decrease (:: @ map (function (_ diff)
+                          (|>> (n/- diff) _;wrap))
+                  r.nat)]
+    (_.test "Associativity."
+            ((comparison n/=)
+             (|> (injection sample) (_;map increase) _;join (_;map decrease) _;join)
+             (|> (injection sample) (_;map (|>> increase (_;map decrease) _;join)) _;join)))))
+
+(def: #export (spec injection comparison monad)
+  (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
+  (_.context (%name (name-of /.Monad))
+             ($_ _.and
+                 (..left-identity injection comparison monad)
+                 (..right-identity injection comparison monad)
+                 (..associativity injection comparison monad)
+                 )))