monads: Add the state monad.

* guix/monads.scm (state-return, state-bind, run-with-state,
  current-state, set-current-state, state-push, state-pop): New
  procedures.
  (%state-monad): New variable.
* tests/monads.scm (%monads): Add %STATE-MONAD.
  (%monad-run): Add 'run-with-state'.
  (values->list): New macro.
  ("set-current-state", "state-push etc."): New tests.
This commit is contained in:
Ludovic Courtès 2015-01-17 18:46:41 +01:00
parent 5db3719153
commit 81a97734e0
3 changed files with 98 additions and 3 deletions

View File

@ -51,6 +51,7 @@
(eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet* 'scheme-indent-function 2))
(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-store 'scheme-indent-function 1))
(eval . (put 'run-with-state 'scheme-indent-function 1))
;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols. ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
;; This notably allows '(' in Paredit to not insert a space when the ;; This notably allows '(' in Paredit to not insert a space when the

View File

@ -46,7 +46,16 @@
anym anym
;; Concrete monads. ;; 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: ;;; Commentary:
;;; ;;;
@ -291,4 +300,58 @@ lifted in MONAD, for which PROC returns true."
(bind identity-bind) (bind identity-bind)
(return identity-return)) (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 ;;; monads.scm end here

View File

@ -37,11 +37,16 @@
(open-connection-for-tests)) (open-connection-for-tests))
(define %monads (define %monads
(list %identity-monad %store-monad)) (list %identity-monad %store-monad %state-monad))
(define %monad-run (define %monad-run
(list identity (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") (test-begin "monads")
@ -206,6 +211,32 @@
%monads %monads
%monad-run)) %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") (test-end "monads")