From 81a97734e04fa40412b2d44ccfae1b4796257648 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 17 Jan 2015 18:46:41 +0100 Subject: monads: Add the state monad. * guix/monads.scm (state-return, state-bind, run-with-state, current-state, set-current-state, state-push, state-pop): New procedures. (%state-monad): New variable. * tests/monads.scm (%monads): Add %STATE-MONAD. (%monad-run): Add 'run-with-state'. (values->list): New macro. ("set-current-state", "state-push etc."): New tests. --- tests/monads.scm | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) (limited to 'tests/monads.scm') diff --git a/tests/monads.scm b/tests/monads.scm index 347a255072..57a8e66797 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -37,11 +37,16 @@ (open-connection-for-tests)) (define %monads - (list %identity-monad %store-monad)) + (list %identity-monad %store-monad %state-monad)) (define %monad-run (list identity - (cut run-with-store %store <>))) + (cut run-with-store %store <>) + (cut run-with-state <> '()))) + +(define-syntax-rule (values->list exp) + (call-with-values (lambda () exp) + list)) (test-begin "monads") @@ -206,6 +211,32 @@ %monads %monad-run)) +(test-equal "set-current-state" + (list '(a a d) 'd) + (values->list + (run-with-state + (mlet* %state-monad ((init (current-state)) + (init2 (set-current-state 'b))) + (mbegin %state-monad + (set-current-state 'c) + (set-current-state 'd) + (mlet %state-monad ((last (current-state))) + (return (list init init2 last))))) + 'a))) + +(test-equal "state-push etc." + (list '((z . 2) (p . (1)) (a . (1))) '(2 1)) + (values->list + (run-with-state + (mbegin %state-monad + (state-push 1) ;(1) + (state-push 2) ;(2 1) + (mlet* %state-monad ((z (state-pop)) ;(1) + (p (current-state)) + (a (state-push z))) ;(2 1) + (return `((z . ,z) (p . ,p) (a . ,a))))) + '()))) + (test-end "monads") -- cgit v1.2.3