diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-10 22:40:29 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-10 23:45:29 +0200 |
commit | 3d7a71bfdbbc80409ed6baa27c63dbae9c471ca8 (patch) | |
tree | 4350f8e92c8143af574598d75249789da337ae18 /module/hnh/util/state-monad.scm | |
parent | Add init+last. (diff) | |
download | calp-3d7a71bfdbbc80409ed6baa27c63dbae9c471ca8.tar.gz calp-3d7a71bfdbbc80409ed6baa27c63dbae9c471ca8.tar.xz |
Add eval- and exec-state.
Diffstat (limited to '')
-rw-r--r-- | module/hnh/util/state-monad.scm | 22 |
1 files changed, 21 insertions, 1 deletions
diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm index 67716a5b..91201583 100644 --- a/module/hnh/util/state-monad.scm +++ b/module/hnh/util/state-monad.scm @@ -13,7 +13,8 @@ :use-module (ice-9 curried-definitions) :replace (do mod) :export (with-temp-state - <$> return get get* put put* sequence lift)) + <$> return get get* put put* sequence lift + eval-state exec-state)) (define-syntax do (syntax-rules (<- let =) @@ -98,3 +99,22 @@ (define (lift proc . arguments) (do xs <- (sequence arguments) (return (apply proc xs)))) + + +;; Run state, returning value +(define (eval-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (r . _) r))) + +;; Run state, returning state +(define (exec-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (_ . v) (apply values v)))) |