State Transformer

src/state-transformer.lfe

@@ -0,0 +1,53 @@
+(defmodule state-transformer
+  (behaviour monad)
+  (export all))
+
+(include-lib "include/monads.lfe")
+
+(defun new (inner-monad)
+  (tuple 'state-transformer inner-monad))
+
+(defun return
+  ((x (tuple 'state-transformer inner-monad))
+   (lambda (s) (call inner-monad 'return (tuple x s)))))
+
+(defun fail
+  ((reason (tuple 'state-transformer inner-monad))
+   (lambda (_) (call inner-monad 'fail reason))))
+
+(defun >>=
+  ((x f (tuple 'maybe-transformer inner-monad))
+   (lambda (s)
+     (call inner-monad '>>=
+       (funcall x f)
+       (match-lambda (((tuple x1 s1)) (funcall (funcall f x1) s1)))))))
+
+(defun get (_)
+  (lambda (s)
+    (tuple s s)))
+
+(defun put (s _)
+  (lambda (_)
+    (tuple 'ok s)))
+
+(defun modify
+  ((f (tuple 'state-transformer inner-monad))
+   (lambda (s)
+     (tuple 'ok (call inner-monad 'return (funcall f s))))))
+
+(defun eval
+  ((m s (tuple 'state-transformer inner-monad))
+   (call inner-monad '>>=
+     (funcall m s)
+     (match-lambda (((tuple x s1)) x)))))
+
+(defun exec
+  ((m s (tuple 'state-transformer inner-monad))
+   (call inner-monad '>>=
+     (funcall m s)
+     (match-lambda (((tuple x s1)) s1)))))
+
+(defun run
+  ((m s (tuple 'state-transformer inner-monad))
+   (funcall m s)))
+

test/unit/unit-state-transformer-tests.lfe

@@ -0,0 +1,39 @@
+(defmodule unit-state-transformer-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")
+
+(deftestskip foo
+  (is 'false))
+
+(deftest eval
+  (is-equal 5
+            (let* ((m (: state-transformer new 'identity-monad))
+                   (mval (call m 'return 5)))
+              (call m 'eval mval 'undefined))))
+
+(deftest exec-unchanged
+  (is-equal 'foo
+            (let* ((m (: state-transformer new 'identity-monad))
+                   (mval (call m 'return 5)))
+              (call m 'exec mval 'foo))))
+
+(deftest exec-double
+  (is-equal 10
+            (let ((m (: state-transformer new 'identity-monad)))
+              (call m 'exec
+                (do-m m
+                      (call m 'modify (lambda (x) (* x 2))))
+                5))))
+
+(deftest exec-fail
+  (is-throw #(error value)
+            (let ((m (: state-transformer new 'identity-monad)))
+              (call m 'exec
+                (call m 'fail 'value)
+                'undefined))))