diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | guix/monads.scm | 65 | ||||
| -rw-r--r-- | tests/monads.scm | 35 |
3 files changed, 98 insertions, 3 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index b099068dac..b82d0494e4 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -51,6 +51,7 @@ (eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet 'scheme-indent-function 2)) (eval . (put 'run-with-store 'scheme-indent-function 1)) + (eval . (put 'run-with-state 'scheme-indent-function 1)) ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols. ;; This notably allows '(' in Paredit to not insert a space when the diff --git a/guix/monads.scm b/guix/monads.scm index 7fec3d5168..f97f4add5d 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -46,7 +46,16 @@ anym ;; Concrete monads. - %identity-monad)) + %identity-monad + + %state-monad + state-return + state-bind + current-state + set-current-state + state-push + state-pop + run-with-state)) ;;; Commentary: ;;; @@ -291,4 +300,58 @@ lifted in MONAD, for which PROC returns true." (bind identity-bind) (return identity-return)) + +;;; +;;; State monad. +;;; + +(define-inlinable (state-return value) + (lambda (state) + (values value state))) + +(define-inlinable (state-bind mvalue mproc) + "Bind MVALUE, a value in the state monad, and pass it to MPROC." + (lambda (state) + (call-with-values + (lambda () + (mvalue state)) + (lambda (value state) + ;; Note: as of Guile 2.0.11, declaring a variable to hold the result + ;; of (mproc value) prevents a bit of unfolding/inlining. + ((mproc value) state))))) + +(define-monad %state-monad + (bind state-bind) + (return state-return)) + +(define* (run-with-state mval #:optional (state '())) + "Run monadic value MVAL starting with STATE as the initial state. Return +two values: the resulting value, and the resulting state." + (mval state)) + +(define-inlinable (current-state) + "Return the current state as a monadic value." + (lambda (state) + (values state state))) + +(define-inlinable (set-current-state value) + "Set the current state to VALUE and return the previous state as a monadic +value." + (lambda (state) + (values state value))) + +(define (state-pop) + "Pop a value from the current state and return it as a monadic value. The +state is assumed to be a list." + (lambda (state) + (match state + ((head . tail) + (values head tail))))) + +(define (state-push value) + "Push VALUE to the current state, which is assumed to be a list, and return +the previous state as a monadic value." + (lambda (state) + (values state (cons value state)))) + ;;; monads.scm end here 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") |