diff --git a/include/monad-tests.lfe b/include/monad-tests.lfe index 7630bba..19b3301 100644 --- a/include/monad-tests.lfe +++ b/include/monad-tests.lfe @@ -1,5 +1,5 @@ (defmacro evaluate-m (monad mval) - `(cond ((: calrissian-util implements? 'calrissian-state ,monad) + `(cond ((calrissian-util:implements? 'calrissian-state ,monad) (call ,monad 'run ,mval 'undefined)) ('true ,mval))) @@ -43,32 +43,32 @@ (f (lambda (n) (return ,monad (* 3 n))))) (is-equal-m ,monad (>>= ,monad (return ,monad a) f) (funcall f a)))) - + (deftest monad-right-identity (let ((m (return ,monad 3))) (is-equal-m ,monad (>>= ,monad m (lambda (m') (return ,monad m'))) m))) - + (deftest monad-associativity (let ((m (return ,monad 3)) (f (lambda (n) (return ,monad (* 3 n)))) (g (lambda (n) (return ,monad (+ 5 n))))) (is-equal-m ,monad (>>= ,monad (>>= ,monad m f) g) (>>= ,monad m (lambda (x) (>>= ,monad (funcall f x) g)))))) - + (deftest monad-do-left-identity (let ((a 3) (f (lambda (n) (return ,monad (* 3 n))))) (is-equal-m ,monad (do-m ,monad (a' <- (return ,monad a)) (funcall f a')) (do-m ,monad (funcall f a))))) - + (deftest monad-do-right-identity (let ((m (return ,monad 3))) (is-equal-m ,monad (do-m ,monad (x <- m) (return ,monad x)) (do-m ,monad m)))) - + (deftest monad-do-associativity (let ((m (return ,monad 3)) (f (lambda (n) (return ,monad (* 3 n)))) diff --git a/include/monads.lfe b/include/monads.lfe index 59f2c19..5904a49 100644 --- a/include/monads.lfe +++ b/include/monads.lfe @@ -3,14 +3,14 @@ ;; Provide the state monad in terms of the state transformer (''state `(transformer 'state 'identity)) (_ - `(list_to_atom (lists:flatten (list "calrissian-" - (atom_to_list ,name) - "-monad")))))) + `(list_to_atom (lists:flatten `("calrissian-" + ,(atom_to_list ,name) + "-monad")))))) (defmacro transformer (name inner-monad) - `(tuple (list_to_atom (lists:flatten (list "calrissian-" - (atom_to_list ,name) - "-transformer"))) + `(tuple (list_to_atom (lists:flatten `("calrissian-" + ,(atom_to_list ,name) + "-transformer"))) (monad ,inner-monad))) (defmacro do-m args @@ -31,7 +31,7 @@ `(call ,monad 'fail ,expr)) (defmacro sequence (monad list) - `(: lists foldr + `(lists:foldr (lambda (m acc) (mcons ,monad m acc)) (return ,monad []) ,list)) diff --git a/src/calrissian-error-monad.lfe b/src/calrissian-error-monad.lfe index 0beffd0..a76e8a7 100644 --- a/src/calrissian-error-monad.lfe +++ b/src/calrissian-error-monad.lfe @@ -5,9 +5,9 @@ (fail 1))) (defun >>= - (((tuple 'error reason) f) - (tuple 'error reason)) - (((tuple 'ok value) f) + ((`#(error ,reason) f) + `#(error ,reason)) + ((`#(ok ,value) f) (funcall f value)) (('ok f) (funcall f 'ok))) @@ -16,7 +16,7 @@ (('ok) 'ok) ((x) - (tuple 'ok x))) + `#(ok ,x))) (defun fail (reason) - (tuple 'error reason)) + `#(error ,reason)) diff --git a/src/calrissian-identity-monad.lfe b/src/calrissian-identity-monad.lfe index f090464..6eb1af4 100644 --- a/src/calrissian-identity-monad.lfe +++ b/src/calrissian-identity-monad.lfe @@ -8,4 +8,6 @@ (funcall f x)) (defun return (x) x) -(defun fail (x) (throw (tuple 'error x))) + +(defun fail (x) + (throw `#(error ,x))) diff --git a/src/calrissian-maybe-monad.lfe b/src/calrissian-maybe-monad.lfe index 77160b5..25a728b 100644 --- a/src/calrissian-maybe-monad.lfe +++ b/src/calrissian-maybe-monad.lfe @@ -7,8 +7,11 @@ (defun >>= (('nothing f) 'nothing) - (((tuple 'just x) f) + ((`#(just ,x) f) (funcall f x))) -(defun return (x) (tuple 'just x)) -(defun fail (_) 'nothing) +(defun return (x) + `#(just ,x)) + +(defun fail (_) + 'nothing) diff --git a/src/calrissian-monad.lfe b/src/calrissian-monad.lfe index 81a636d..d2bafc7 100644 --- a/src/calrissian-monad.lfe +++ b/src/calrissian-monad.lfe @@ -3,15 +3,17 @@ (do-transform 2))) (defun behaviour_info - (('callbacks) (list #(>>= 2) - #(return 1) - #(fail 1))) + (('callbacks) '(#(>>= 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))) - ) + ((monad `(,h . ())) + h) + ((monad `((,f <- ,m) . ,t)) + `(>>= ,monad + ,m + (lambda (,f) ,(do-transform monad t)))) + ((monad `(,h . ,t)) + `(>> ,monad ,h ,(do-transform monad t)))) diff --git a/src/calrissian-state-transformer.lfe b/src/calrissian-state-transformer.lfe index eb30588..052b05a 100644 --- a/src/calrissian-state-transformer.lfe +++ b/src/calrissian-state-transformer.lfe @@ -4,57 +4,57 @@ (include-lib "include/monads.lfe") (defun new (inner-monad) - (tuple 'calrissian-state-transformer inner-monad)) + `#(calrissian-state-transformer ,inner-monad)) (defun return - ((x (tuple 'calrissian-state-transformer inner-monad)) + ((x `#(calrissian-state-transformer ,inner-monad)) (lambda (s) (call inner-monad 'return (tuple x s))))) (defun fail - ((reason (tuple 'calrissian-state-transformer inner-monad)) + ((reason `#(calrissian-state-transformer ,inner-monad)) (lambda (_) (call inner-monad 'fail reason)))) (defun >>= - ((x f (tuple 'calrissian-state-transformer inner-monad)) + ((x f `#(calrissian-state-transformer ,inner-monad)) (lambda (s) (call inner-monad '>>= (funcall x s) - (match-lambda (((tuple x1 s1)) (funcall (funcall f x1) s1))))))) + (match-lambda ((`#(,x1 ,s1)) (funcall (funcall f x1) s1))))))) (defun get (_) (lambda (s) - (tuple s s))) + `#(,s ,s))) (defun put (s _) (lambda (_) - (tuple 'ok s))) + `#(ok ,s))) (defun modify - ((f (tuple 'calrissian-state-transformer inner-monad)) + ((f `#(calrissian-state-transformer ,inner-monad)) (lambda (s) - (tuple 'ok (call inner-monad 'return (funcall f s)))))) + `#(ok ,(call inner-monad 'return (funcall f s)))))) (defun modify-and-return - ((f (tuple 'calrissian-state-transformer inner-monad)) + ((f `#(calrissian-state-transformer ,inner-monad)) (lambda (s) (let ((newstate (call inner-monad 'return (funcall f s)))) - (tuple newstate newstate))))) + `#(,newstate ,newstate))))) (defun eval - ((m s (tuple 'calrissian-state-transformer inner-monad)) + ((m s `#(calrissian-state-transformer ,inner-monad)) (call inner-monad '>>= (funcall m s) - (match-lambda (((tuple x s1)) + (match-lambda ((`#(,x ,s1)) (call inner-monad 'return x)))))) (defun exec - ((m s (tuple 'calrissian-state-transformer inner-monad)) + ((m s `#(calrissian-state-transformer ,inner-monad)) (call inner-monad '>>= (funcall m s) - (match-lambda (((tuple x s1)) + (match-lambda ((`#(,x ,s1)) (call inner-monad 'return s1)))))) (defun run - ((m s (tuple 'calrissian-state-transformer inner-monad)) + ((m s `#(calrissian-state-transformer ,inner-monad)) (funcall m s))) diff --git a/src/calrissian-state.lfe b/src/calrissian-state.lfe index 6fc37a0..b35f703 100644 --- a/src/calrissian-state.lfe +++ b/src/calrissian-state.lfe @@ -2,11 +2,11 @@ (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))) + (('callbacks) `(#(run 2) + #(get 0) + #(put 1) + #(modify 1) + #(modify-and-return 1) + #(exec 2) + #(eval 2))) ((_) 'undefined)) \ No newline at end of file diff --git a/src/calrissian-util.lfe b/src/calrissian-util.lfe index 24a6a53..6fb31a1 100644 --- a/src/calrissian-util.lfe +++ b/src/calrissian-util.lfe @@ -14,31 +14,32 @@ `(#(calrissian ,(get-version))))) (defun module-info - (((tuple module _args)) + ((`#(,module ,_args)) ;; Report exported function arities as (arity - 1) to account for ;; the extra argument supplied to tuple modules (let ((fix-info (lambda (info-plist) - (let* ((exports (: proplists get_value 'exports info-plist)) + (let* ((exports (proplists:get_value 'exports info-plist)) (fix-arity (match-lambda ;; module_info is added by the compiler and therefore remains as-is - (((tuple 'module_info arity)) (tuple 'module_info arity)) - (((tuple fun arity)) (tuple fun (- arity 1))))) - (info-dict (: dict from_list info-plist)) - (new-dict (: dict store 'exports (: lists map fix-arity exports) info-dict)) - (new-plist (: dict to_list new-dict))) + ((`#(module_info ,arity)) `#(module_info ,arity)) + ((`#(,fun ,arity)) `#(,fun ,(- arity 1))))) + (info-dict (dict:from_list info-plist)) + (new-dict (dict:store 'exports (lists:map fix-arity exports) info-dict)) + (new-plist (dict:to_list new-dict))) new-plist)))) (funcall fix-info (module-info module)))) - ((module) (call module 'module_info))) + ((module) + (call module 'module_info))) (defun module-info (module key) - (: proplists get_value key (module-info module))) + (proplists:get_value key (module-info module))) (defun implements? (behaviour module) (let* ((exports (module-info module 'exports)) - (exported? (lambda (definition) (: lists member definition exports)))) - (: lists all exported? - (call behaviour 'behaviour_info 'callbacks)))) + (exported? (lambda (definition) (lists:member definition exports)))) + (lists:all exported? + (call behaviour 'behaviour_info 'callbacks)))) (defun exports? (definition module) - (: lists member definition - (module-info module 'exports))) \ No newline at end of file + (lists:member definition + (module-info module 'exports)))