aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--guix/monads.scm65
-rw-r--r--tests/monads.scm35
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")