diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-03-23 01:17:29 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-10 23:45:29 +0200 |
commit | 38bbb98e4383ec9897a4a4dac374fdff59c1a7b8 (patch) | |
tree | 1c754798d3613d9221ed6d3d76ebd1c964ff5b96 /module/hnh | |
parent | Extend (web http) to allow adding new methods. (diff) | |
download | calp-38bbb98e4383ec9897a4a4dac374fdff59c1a7b8.tar.gz calp-38bbb98e4383ec9897a4a4dac374fdff59c1a7b8.tar.xz |
Borrow state-monad from guile-dns.
Also imports the tests from guile-dns. Minor rewrites have been done, to
match a differing project structure.
Diffstat (limited to '')
-rw-r--r-- | module/hnh/util/state-monad.scm | 100 |
1 files changed, 100 insertions, 0 deletions
diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm new file mode 100644 index 00000000..67716a5b --- /dev/null +++ b/module/hnh/util/state-monad.scm @@ -0,0 +1,100 @@ +;;; Commentary: +;;; A state monad similar to (and directly influenced by) the one found in in +;;; Haskell +;;; Each procedure can either explicitly take the state as a curried last +;;; argument, or use the `do' notation, which handles that implicitly. +;;; Each procedure MUST return two values, where the second value is the state +;;; value which will be chained. +;;; +;;; Code borrowed from guile-dns +;;; Code: + +(define-module (hnh util state-monad) + :use-module (ice-9 curried-definitions) + :replace (do mod) + :export (with-temp-state + <$> return get get* put put* sequence lift)) + +(define-syntax do + (syntax-rules (<- let =) + ((_ (a ...) <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a* . next-state) + (apply (lambda (a ...) + (apply (do rest ...) + next-state)) + a*))))) + ((_ a <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a . next-state) + (apply (do rest ...) + next-state))))) + + ((_ a = b rest ...) + (let ((a b)) + (do rest ...))) + + ((_ a) + (lambda state (apply a state))) + ((_ a rest ...) + (lambda state + (call-with-values (lambda () (apply a state)) + (lambda (_ . next-state) + (apply (do rest ...) + next-state))))))) + + +(define (with-temp-state state* op) + (do old <- (get*) + (apply put* state*) + ret-value <- op + (apply put* old) + (return ret-value))) + + +(define (<$> f y) + (do tmp <- y + (return (f tmp)))) + +(define ((return x) . y) + (apply values x y)) + +(define ((get*) . state) + "Like @code{get}, but always returns a list" + (values state state)) + +(define ((get) fst . state) + "If state contains a single variable return that, otherwise, return a list of all variables in state" + (if (null? state) + (values fst fst) + (apply values (cons fst state) fst state))) + +(define ((put . new-state) fst . old-state) + (if (null? old-state) + (apply values fst new-state) + (apply values (cons fst old-state) new-state))) + +;; Like put, but doesn't return anything (useful) +(define ((put* . new-state) . _) + (apply values #f new-state)) + +(define (mod proc) + (do + a <- (get) + (put (proc a)))) + +;; ms must be a list of continuations +(define (sequence ms) + (if (null? ms) + (return '()) + (do + fst <- (car ms) + rest <- (sequence (cdr ms)) + (return (cons fst rest))))) + + +(define (lift proc . arguments) + (do xs <- (sequence arguments) + (return (apply proc xs)))) |