diff options
-rw-r--r-- | module/hnh/util/state-monad.scm | 100 | ||||
-rw-r--r-- | tests/test/hnh-util-state-monad.scm | 120 | ||||
-rw-r--r-- | tests/test/state-monad.scm | 121 |
3 files changed, 341 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)))) diff --git a/tests/test/hnh-util-state-monad.scm b/tests/test/hnh-util-state-monad.scm new file mode 100644 index 00000000..353c47e9 --- /dev/null +++ b/tests/test/hnh-util-state-monad.scm @@ -0,0 +1,120 @@ +(define-module (test hnh-util-state-monad) + :use-module (srfi srfi-64) + :use-module (hnh util state-monad)) + + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) + + diff --git a/tests/test/state-monad.scm b/tests/test/state-monad.scm new file mode 100644 index 00000000..a4e28b78 --- /dev/null +++ b/tests/test/state-monad.scm @@ -0,0 +1,121 @@ +;;; Borrowed from guile-dns + +(define-module (test state-monad) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + ) + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) |