blob: 7e81b387593c87dc1a6a3fb2d3bfcaae0676c871 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
(define-module (control monad state)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (control monad)
#:export (make-state return-state
get put
run-state)
#:re-export (>>= >>))
;; Alternative implementation of get.
;; See https://hackage.haskell.org/package/mtl-2.2.1/docs/src/Control.Monad.State.Class.html#get
;;; newtype State = st-list -> st-list
;;; state procedure <=> st-list -> st-list
;;; state list <=> (list ret st)
;;; Wrapper around a procedure with signature:
;;; (st-list -> st-list). Wrapped to allow goops
;;; multiple dispatch to do its thing.
(define-class <state> ()
(proc #:init-keyword #:proc
#:getter proc))
;; (st-list -> st-list) -> State
(define (make-state proc)
"Creates a state object from a State procedure"
(make <state> #:proc proc))
(define-method (>>= (st <state>) f)
(lambda (st-list)
(let ((new-st-list ((proc st) st-list)))
(match new-st-list
((v _)
((proc (f v)) new-st-list))))))
(define-method (>> (a <state>) (b <state>))
(lambda (st-list-a)
(let ((st-list-b ((proc a) st-list-a)))
((proc b) st-list-b))))
(define (return-state v)
"Sets the return value to v"
(make-state
(lambda (st-list)
(cons v (cdr st-list)))))
(define (get)
"Sets the return value of state to st."
(make-state
(lambda (st-list)
(match st-list
((_ st)
(list st st))))))
(define (put v)
"Sets st to v."
(make-state
(lambda (st-list)
(list '() v))))
(define-method (run-state st-proc init)
"Exec state with init as starting state value and st."
(st-proc (list init init)))
|
