summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-01-17 18:46:41 +0100
committerLudovic Courtès <ludo@gnu.org>2015-01-17 23:45:48 +0100
commit81a97734e04fa40412b2d44ccfae1b4796257648 (patch)
treedbb6513d891d778c41abe564891466c564721339 /tests
parent5db3719153ccabd192eadaf99b14ad1149172c5b (diff)
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.
Diffstat (limited to 'tests')
-rw-r--r--tests/monads.scm35
1 files changed, 33 insertions, 2 deletions
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")