diff --git a/include/monads.lfe b/include/monads.lfe new file mode 100644 index 0000000..15736e2 --- /dev/null +++ b/include/monads.lfe @@ -0,0 +1,13 @@ +(defmacro do args + (let ((monad (car args)) + (statements (cdr args))) + (monad:do-transform monad statements))) + +(defmacro >>= (monad m f) + `(: ,monad >>= ,m ,f)) + +(defmacro >> (monad m1 m2) + `(: ,monad >>= ,m1 (lambda (_) ,m2))) + +(defmacro return (monad expr) + `(: ,monad return ,expr)) diff --git a/src/maybe-monad.lfe b/src/maybe-monad.lfe new file mode 100644 index 0000000..5ff3264 --- /dev/null +++ b/src/maybe-monad.lfe @@ -0,0 +1,14 @@ +(defmodule maybe-monad + (behaviour monad) + (export (>>= 2) + (return 1) + (fail 1))) + +(defun >>= + (('nothing f) + 'nothing) + (((tuple 'just x) f) + (funcall f x))) + +(defun return (x) (tuple 'just x)) +(defun fail (_) 'nothing) diff --git a/src/maybe.lfe b/src/maybe.lfe deleted file mode 100644 index c552732..0000000 --- a/src/maybe.lfe +++ /dev/null @@ -1,25 +0,0 @@ -(defmodule maybe - (export all)) - -(defun my-adder (x y) - (+ x (+ y 1))) - -(defun >>= - (('nothing f) - 'nothing) - (((tuple 'just x) f) - (funcall f x))) - -(defun >> (a b) - (>>= a (lambda (_) b))) - -(defun return (x) (tuple 'just x)) -(defun fail (_) 'nothing) - -(defun do-statement - (((cons h '())) h) - (((cons (list f '<- m) t)) (list ': 'maybe '>>= - m - (list 'lambda (list f) (do-statement t)))) - (((cons h t)) (list ': 'maybe '>> h (do-statement t))) - ) diff --git a/src/monad.lfe b/src/monad.lfe new file mode 100644 index 0000000..00e7dd2 --- /dev/null +++ b/src/monad.lfe @@ -0,0 +1,17 @@ +(defmodule monad + (export (behaviour-info 1) + (do-transform 2))) + +(defun behaviour-info + (('callbacks) (list #(>>= 2) + #(return 1) + #(fail 1))) + ((_) 'undefined)) + +(defun do-transform + ((monad (cons h '())) h) + ((monad (cons (list f '<- m) t)) (list ': monad '>>= + m + (list 'lambda (list f) (do-transform monad t)))) + ((monad (cons h t)) (list '>> monad h (do-transform monad t))) + ) diff --git a/test/unit/unit-maybe-tests.lfe b/test/unit/unit-maybe-monad-tests.lfe similarity index 57% rename from test/unit/unit-maybe-tests.lfe rename to test/unit/unit-maybe-monad-tests.lfe index dfe4724..38c5a24 100644 --- a/test/unit/unit-maybe-tests.lfe +++ b/test/unit/unit-maybe-monad-tests.lfe @@ -1,4 +1,4 @@ -(defmodule unit-maybe-tests +(defmodule unit-maybe-monad-tests (export all) (import (from lfeunit-util @@ -6,27 +6,27 @@ (check-wrong-assert-exception 2)))) (include-lib "deps/lfeunit/include/lfeunit-macros.lfe") -(include-lib "include/maybe.lfe") +(include-lib "include/monads.lfe") (deftest bind-nothing (is-equal 'nothing - (maybe:>>= 'nothing + (>>= maybe-monad 'nothing (lambda (x) (+ 5 x))))) (deftest bind-nothing-error (is-equal 'nothing - (maybe:>>= 'nothing + (>>= maybe-monad 'nothing (lambda (_) (error 'bad-func))))) (deftest bind-five (is-equal 10 - (maybe:>>= (tuple 'just 5) + (>>= maybe-monad (tuple 'just 5) (lambda (x) (+ 5 x))))) (deftest bind-fold (is-equal #(just 3) - (let ((minc (lambda (x) (maybe:return (+ 1 x)))) - (bind (lambda (f m) (maybe:>>= m f)))) + (let ((minc (lambda (x) (return maybe-monad (+ 1 x)))) + (bind (lambda (f m) (>>= maybe-monad m f)))) (lists:foldr bind #(just 0) (list minc @@ -35,15 +35,17 @@ (deftest >> (is-equal #(just 3) - (maybe:>> #(just 5) #(just 3)))) + (>> maybe-monad #(just 5) #(just 3)))) (deftest do-bindings (is-equal #(just 3) - (do (a <- #(just 1)) - (b <- #(just 2)) - (maybe:return (+ a b))))) + (do maybe-monad + (a <- #(just 1)) + (b <- #(just 2)) + (return maybe-monad (+ a b))))) (deftest do-nobindings (is-equal #(just 3) - (do #(just 5) - #(just 3)))) \ No newline at end of file + (do maybe-monad + #(just 5) + #(just 3)))) \ No newline at end of file