mirror of
https://github.com/correl/calrissian.git
synced 2024-11-23 11:09:58 +00:00
Add macros to simplify monad usage
This commit is contained in:
parent
0914cf5779
commit
99be83ee71
6 changed files with 37 additions and 26 deletions
|
@ -1,3 +1,14 @@
|
||||||
|
(defmacro monad (name)
|
||||||
|
`(list_to_atom (lists:flatten (list "calrissian-"
|
||||||
|
(atom_to_list ,name)
|
||||||
|
"-monad"))))
|
||||||
|
|
||||||
|
(defmacro transformer (name inner-monad)
|
||||||
|
`(tuple (list_to_atom (lists:flatten (list "calrissian-"
|
||||||
|
(atom_to_list ,name)
|
||||||
|
"-transformer")))
|
||||||
|
(monad ,inner-monad)))
|
||||||
|
|
||||||
(defmacro do-m args
|
(defmacro do-m args
|
||||||
(let ((monad (car args))
|
(let ((monad (car args))
|
||||||
(statements (cdr args)))
|
(statements (cdr args)))
|
||||||
|
|
|
@ -9,28 +9,28 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
(include-lib "include/monad-tests.lfe")
|
(include-lib "include/monad-tests.lfe")
|
||||||
|
|
||||||
(test-monad 'calrissian-error-monad)
|
(test-monad (monad 'error))
|
||||||
|
|
||||||
(deftest return-ok
|
(deftest return-ok
|
||||||
(is-equal 'ok
|
(is-equal 'ok
|
||||||
(return 'calrissian-error-monad 'ok)))
|
(return (monad 'error) 'ok)))
|
||||||
|
|
||||||
(deftest return-value
|
(deftest return-value
|
||||||
(is-equal #(ok 123)
|
(is-equal #(ok 123)
|
||||||
(return 'calrissian-error-monad 123)))
|
(return (monad 'error) 123)))
|
||||||
|
|
||||||
(deftest fail-with-reason
|
(deftest fail-with-reason
|
||||||
(is-equal #(error reason)
|
(is-equal #(error reason)
|
||||||
(fail 'calrissian-error-monad 'reason)))
|
(fail (monad 'error) 'reason)))
|
||||||
|
|
||||||
(deftest fail-short-circuits-value
|
(deftest fail-short-circuits-value
|
||||||
(is-equal (fail 'calrissian-error-monad 'something-bad)
|
(is-equal (fail (monad 'error) 'something-bad)
|
||||||
(>> 'calrissian-error-monad
|
(>> (monad 'error)
|
||||||
(fail 'calrissian-error-monad 'something-bad)
|
(fail (monad 'error) 'something-bad)
|
||||||
(return 'calrissian-error-monad 123))))
|
(return (monad 'error) 123))))
|
||||||
|
|
||||||
(deftest fail-short-circuits-error
|
(deftest fail-short-circuits-error
|
||||||
(is-equal #(error something-bad)
|
(is-equal #(error something-bad)
|
||||||
(>> 'calrissian-error-monad
|
(>> (monad 'error)
|
||||||
(fail 'calrissian-error-monad 'something-bad)
|
(fail (monad 'error) 'something-bad)
|
||||||
(throw 'error))))
|
(throw 'error))))
|
||||||
|
|
|
@ -9,12 +9,12 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
(include-lib "include/monad-tests.lfe")
|
(include-lib "include/monad-tests.lfe")
|
||||||
|
|
||||||
(test-monad 'calrissian-identity-monad)
|
(test-monad (monad 'identity))
|
||||||
|
|
||||||
(deftest identity
|
(deftest identity
|
||||||
(is-equal 'ok
|
(is-equal 'ok
|
||||||
(return 'calrissian-identity-monad 'ok)))
|
(return (monad 'identity) 'ok)))
|
||||||
|
|
||||||
(deftest fail-with-error
|
(deftest fail-with-error
|
||||||
(is-throw #(error value)
|
(is-throw #(error value)
|
||||||
(fail 'calrissian-identity-monad 'value)))
|
(fail (monad 'identity) 'value)))
|
|
@ -9,22 +9,22 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
(include-lib "include/monad-tests.lfe")
|
(include-lib "include/monad-tests.lfe")
|
||||||
|
|
||||||
(test-monad 'calrissian-maybe-monad)
|
(test-monad (monad 'maybe))
|
||||||
|
|
||||||
(deftest nothing-short-circuits-value
|
(deftest nothing-short-circuits-value
|
||||||
(is-equal 'nothing
|
(is-equal 'nothing
|
||||||
(>>= 'calrissian-maybe-monad 'nothing
|
(>>= (monad 'maybe) 'nothing
|
||||||
(lambda (x) (+ 5 x)))))
|
(lambda (x) (+ 5 x)))))
|
||||||
|
|
||||||
(deftest nothing-short-circuits-error
|
(deftest nothing-short-circuits-error
|
||||||
(is-equal 'nothing
|
(is-equal 'nothing
|
||||||
(>>= 'calrissian-maybe-monad 'nothing
|
(>>= (monad 'maybe) 'nothing
|
||||||
(lambda (_) (error 'bad-func)))))
|
(lambda (_) (error 'bad-func)))))
|
||||||
|
|
||||||
(deftest fold-increment-value
|
(deftest fold-increment-value
|
||||||
(is-equal #(just 3)
|
(is-equal #(just 3)
|
||||||
(let ((minc (lambda (x) (return 'calrissian-maybe-monad (+ 1 x))))
|
(let ((minc (lambda (x) (return (monad 'maybe) (+ 1 x))))
|
||||||
(bind (lambda (f m) (>>= 'calrissian-maybe-monad m f))))
|
(bind (lambda (f m) (>>= (monad 'maybe) m f))))
|
||||||
(lists:foldr bind
|
(lists:foldr bind
|
||||||
#(just 0)
|
#(just 0)
|
||||||
(list minc
|
(list minc
|
||||||
|
|
|
@ -9,4 +9,4 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
(include-lib "include/monad-tests.lfe")
|
(include-lib "include/monad-tests.lfe")
|
||||||
|
|
||||||
(test-monad 'calrissian-state-monad)
|
(test-monad (monad 'state))
|
||||||
|
|
|
@ -9,23 +9,23 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
(include-lib "include/monad-tests.lfe")
|
(include-lib "include/monad-tests.lfe")
|
||||||
|
|
||||||
(test-monad (: calrissian-state-transformer new 'calrissian-identity-monad))
|
(test-monad (transformer 'state 'identity))
|
||||||
|
|
||||||
(deftest eval
|
(deftest eval
|
||||||
(is-equal 5
|
(is-equal 5
|
||||||
(let* ((m (: calrissian-state-transformer new 'calrissian-identity-monad))
|
(let* ((m (transformer 'state 'identity))
|
||||||
(mval (call m 'return 5)))
|
(mval (call m 'return 5)))
|
||||||
(call m 'eval mval 'undefined))))
|
(call m 'eval mval 'undefined))))
|
||||||
|
|
||||||
(deftest exec-unchanged
|
(deftest exec-unchanged
|
||||||
(is-equal 'foo
|
(is-equal 'foo
|
||||||
(let* ((m (: calrissian-state-transformer new 'calrissian-identity-monad))
|
(let* ((m (transformer 'state 'identity))
|
||||||
(mval (call m 'return 5)))
|
(mval (call m 'return 5)))
|
||||||
(call m 'exec mval 'foo))))
|
(call m 'exec mval 'foo))))
|
||||||
|
|
||||||
(deftest exec-modify
|
(deftest exec-modify
|
||||||
(is-equal 10
|
(is-equal 10
|
||||||
(let ((m (: calrissian-state-transformer new 'calrissian-identity-monad)))
|
(let ((m (transformer 'state 'identity)))
|
||||||
(call m 'exec
|
(call m 'exec
|
||||||
(do-m m
|
(do-m m
|
||||||
(call m 'modify (lambda (x) (* x 2))))
|
(call m 'modify (lambda (x) (* x 2))))
|
||||||
|
@ -33,7 +33,7 @@
|
||||||
|
|
||||||
(deftest exec-put-and-modify
|
(deftest exec-put-and-modify
|
||||||
(is-equal 30
|
(is-equal 30
|
||||||
(let ((m (: calrissian-state-transformer new 'calrissian-identity-monad)))
|
(let ((m (transformer 'state 'identity)))
|
||||||
(call m 'exec
|
(call m 'exec
|
||||||
(do-m m
|
(do-m m
|
||||||
(call m 'put 10)
|
(call m 'put 10)
|
||||||
|
@ -44,7 +44,7 @@
|
||||||
|
|
||||||
(deftest exec-bind-and-modify
|
(deftest exec-bind-and-modify
|
||||||
(is-equal 16
|
(is-equal 16
|
||||||
(let ((m (: calrissian-state-transformer new 'calrissian-identity-monad)))
|
(let ((m (transformer 'state 'identity)))
|
||||||
(call m 'exec
|
(call m 'exec
|
||||||
(do-m m
|
(do-m m
|
||||||
(a <- (call m 'modify-and-return (lambda (x) (+ x 5))))
|
(a <- (call m 'modify-and-return (lambda (x) (+ x 5))))
|
||||||
|
@ -53,7 +53,7 @@
|
||||||
|
|
||||||
(deftest exec-fail
|
(deftest exec-fail
|
||||||
(is-throw #(error value)
|
(is-throw #(error value)
|
||||||
(let ((m (: calrissian-state-transformer new 'calrissian-identity-monad)))
|
(let ((m (transformer 'state 'identity)))
|
||||||
(call m 'exec
|
(call m 'exec
|
||||||
(call m 'fail 'value)
|
(call m 'fail 'value)
|
||||||
'undefined))))
|
'undefined))))
|
||||||
|
|
Loading…
Reference in a new issue