diff --git a/src/state-transformer.lfe b/src/state-transformer.lfe new file mode 100644 index 0000000..7f83927 --- /dev/null +++ b/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))) + diff --git a/test/unit/unit-state-transformer-tests.lfe b/test/unit/unit-state-transformer-tests.lfe new file mode 100644 index 0000000..859c3c9 --- /dev/null +++ b/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))))