mirror of
https://github.com/correl/calrissian.git
synced 2024-11-23 11:09:58 +00:00
Add state monad and behaviour
This commit is contained in:
parent
4ec1a9897d
commit
1ee02b261a
3 changed files with 71 additions and 0 deletions
47
src/state-monad.lfe
Normal file
47
src/state-monad.lfe
Normal file
|
@ -0,0 +1,47 @@
|
|||
(defmodule state-monad
|
||||
(behaviour monad)
|
||||
(behaviour state)
|
||||
(export (return 1)
|
||||
(fail 1)
|
||||
(run 2)
|
||||
(>>= 2)
|
||||
(get 0)
|
||||
(put 1)
|
||||
(modify 1)
|
||||
(modify-and-return 1)
|
||||
(exec 2)
|
||||
(eval 2)))
|
||||
|
||||
(defun return (x) (lambda (state) (tuple x state)))
|
||||
(defun fail (x) (throw (tuple 'error x)))
|
||||
|
||||
(defun run (m state)
|
||||
(funcall m state))
|
||||
|
||||
(defun >>= (m f)
|
||||
(lambda (state)
|
||||
(let (((tuple x s) (run m state)))
|
||||
(run (funcall f x) s))))
|
||||
|
||||
(defun put (state)
|
||||
(lambda (_) (tuple '() state)))
|
||||
|
||||
(defun get ()
|
||||
(lambda (state)
|
||||
(tuple state state)))
|
||||
|
||||
(defun modify (f)
|
||||
(lambda (state)
|
||||
(tuple '() (funcall f state))))
|
||||
|
||||
(defun modify-and-return (f)
|
||||
(lambda (state)
|
||||
(let ((newstate (funcall f state)))
|
||||
(tuple newstate newstate))))
|
||||
|
||||
(defun eval (m state)
|
||||
(let (((tuple x _s) (run m state)))
|
||||
x))
|
||||
(defun exec (m state)
|
||||
(let (((tuple _x s) (run m state)))
|
||||
s))
|
12
src/state.lfe
Normal file
12
src/state.lfe
Normal file
|
@ -0,0 +1,12 @@
|
|||
(defmodule state
|
||||
(export (behaviour_info 1)))
|
||||
|
||||
(defun behaviour_info
|
||||
(('callbacks) (list #(run 2)
|
||||
#(get 0)
|
||||
#(put 1)
|
||||
#(modify 1)
|
||||
#(modify-and-return 1)
|
||||
#(exec 2)
|
||||
#(eval 2)))
|
||||
((_) 'undefined))
|
12
test/unit/unit-state-monad-tests.lfe
Normal file
12
test/unit/unit-state-monad-tests.lfe
Normal file
|
@ -0,0 +1,12 @@
|
|||
(defmodule unit-state-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 'state-monad)
|
Loading…
Reference in a new issue