mirror of
https://github.com/correl/calrissian.git
synced 2024-11-23 19:19:57 +00:00
Remove monad atom evaluation skipping in macros
This commit is contained in:
parent
5721c3fc58
commit
02ada611df
4 changed files with 22 additions and 31 deletions
|
@ -4,25 +4,16 @@
|
||||||
(monad:do-transform monad statements)))
|
(monad:do-transform monad statements)))
|
||||||
|
|
||||||
(defmacro >>= (monad m f)
|
(defmacro >>= (monad m f)
|
||||||
(if (: lfe-utils atom? monad)
|
`(call ,monad '>>= ,m ,f))
|
||||||
`(call ',monad '>>= ,m ,f)
|
|
||||||
`(call ,monad '>>= ,m ,f)))
|
|
||||||
|
|
||||||
(defmacro >> (monad m1 m2)
|
(defmacro >> (monad m1 m2)
|
||||||
(let ((f `(lambda (_) ,m2)))
|
`(call ,monad '>>= ,m1 (lambda (_) , m2)))
|
||||||
(if (: lfe-utils atom? monad)
|
|
||||||
`(call ',monad '>>= ,m1 ,f)
|
|
||||||
`(call ,monad '>>= ,m1 ,f))))
|
|
||||||
|
|
||||||
(defmacro return (monad expr)
|
(defmacro return (monad expr)
|
||||||
(if (: lfe-utils atom? monad)
|
`(call ,monad 'return ,expr))
|
||||||
`(call ',monad 'return ,expr)
|
|
||||||
`(call ,monad 'return ,expr)))
|
|
||||||
|
|
||||||
(defmacro fail (monad expr)
|
(defmacro fail (monad expr)
|
||||||
(if (: lfe-utils atom? monad)
|
`(call ,monad 'fail ,expr))
|
||||||
`(call ',monad 'fail ,expr)
|
|
||||||
`(call ,monad 'fail ,expr)))
|
|
||||||
|
|
||||||
(defmacro sequence (monad list)
|
(defmacro sequence (monad list)
|
||||||
`(: lists foldr
|
`(: lists foldr
|
||||||
|
|
|
@ -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 error-monad)
|
(test-monad 'error-monad)
|
||||||
|
|
||||||
(deftest return-ok
|
(deftest return-ok
|
||||||
(is-equal 'ok
|
(is-equal 'ok
|
||||||
(return error-monad 'ok)))
|
(return 'error-monad 'ok)))
|
||||||
|
|
||||||
(deftest return-value
|
(deftest return-value
|
||||||
(is-equal #(ok 123)
|
(is-equal #(ok 123)
|
||||||
(return error-monad 123)))
|
(return 'error-monad 123)))
|
||||||
|
|
||||||
(deftest fail-with-reason
|
(deftest fail-with-reason
|
||||||
(is-equal #(error reason)
|
(is-equal #(error reason)
|
||||||
(fail error-monad 'reason)))
|
(fail 'error-monad 'reason)))
|
||||||
|
|
||||||
(deftest fail-short-circuits-value
|
(deftest fail-short-circuits-value
|
||||||
(is-equal (fail error-monad 'something-bad)
|
(is-equal (fail 'error-monad 'something-bad)
|
||||||
(>> error-monad
|
(>> 'error-monad
|
||||||
(fail error-monad 'something-bad)
|
(fail 'error-monad 'something-bad)
|
||||||
(return error-monad 123))))
|
(return 'error-monad 123))))
|
||||||
|
|
||||||
(deftest fail-short-circuits-error
|
(deftest fail-short-circuits-error
|
||||||
(is-equal #(error something-bad)
|
(is-equal #(error something-bad)
|
||||||
(>> error-monad
|
(>> 'error-monad
|
||||||
(fail error-monad 'something-bad)
|
(fail 'error-monad '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 identity-monad)
|
(test-monad 'identity-monad)
|
||||||
|
|
||||||
(deftest identity
|
(deftest identity
|
||||||
(is-equal 'ok
|
(is-equal 'ok
|
||||||
(return identity-monad 'ok)))
|
(return 'identity-monad 'ok)))
|
||||||
|
|
||||||
(deftest fail-with-error
|
(deftest fail-with-error
|
||||||
(is-throw #(error value)
|
(is-throw #(error value)
|
||||||
(fail identity-monad 'value)))
|
(fail 'identity-monad '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 maybe-monad)
|
(test-monad 'maybe-monad)
|
||||||
|
|
||||||
(deftest nothing-short-circuits-value
|
(deftest nothing-short-circuits-value
|
||||||
(is-equal 'nothing
|
(is-equal 'nothing
|
||||||
(>>= maybe-monad 'nothing
|
(>>= 'maybe-monad '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
|
||||||
(>>= maybe-monad 'nothing
|
(>>= 'maybe-monad '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 maybe-monad (+ 1 x))))
|
(let ((minc (lambda (x) (return 'maybe-monad (+ 1 x))))
|
||||||
(bind (lambda (f m) (>>= maybe-monad m f))))
|
(bind (lambda (f m) (>>= 'maybe-monad m f))))
|
||||||
(lists:foldr bind
|
(lists:foldr bind
|
||||||
#(just 0)
|
#(just 0)
|
||||||
(list minc
|
(list minc
|
||||||
|
|
Loading…
Reference in a new issue