blob: 40c9ff5e551d289e3ffe7fbf493dadcf5889a024 (
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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
;;; Commentary:
;;
;; The state monad!
;; State is best modelled monadically as a function taking a state object, and
;; returning another state object. This state object is in turn represented as i
;; list where the first value is the last value returned, and the secound value
;; is the internal state.
;;
;; All access to this internal value is done through the methods @code{get},
;; @code{put}, and @code{modify}.
;;
;; One side effect of the @code{<state>} object not being directly accessible is
;; that my trick for multiple dispatch return doesn't work. Which is why this
;; modules also exports @code{return-state} directly.
;;
;;; Code:
(define-module (monad state)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (monad)
#:export (return-state run-state get put modify)
#:re-export (>>= >> return))
;;; 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 a procedure which is in the state monad. This means that it takes a
;;; state list as a curried argument, and it's return is wrappen in a <state>
;;; object.
;;; It's fully possible to create stateful objects without these macros, but it's
;;; ill adviced since that would just be boilerplate.
(define-syntax-rule (define-stateful ((proc args ...) st) body ...)
(define (proc args ...)
(make-state
(lambda (st) body ...))))
(define-syntax-rule (define-stateful-method ((proc args ...) st) body ...)
(define-method (proc args ...)
(make-state
(lambda (st) body ...))))
(define-stateful-method ((>>= (st <state>) (f <procedure>)) st-list)
(let ((new-st-list ((proc st) st-list)))
(match new-st-list
((v _)
((proc (f v)) new-st-list)))))
(define-stateful ((return-state v) st-list)
"Sets the return value to v"
(cons v (cdr st-list)))
(define-method (return (a <state>)) return-state)
(define-stateful ((get) st-list)
"Sets the return value of state to st."
(match st-list
((_ st)
(list st st))))
(define-stateful ((put v) st-list)
"Sets st to v."
(list '() v))
(define-stateful ((modify proc) st-list)
"Applies proc to the value stored in state, and stores it back"
(match st-list
((r s)
(list '() (proc s)))))
(define-method (run-state (st <state>) init)
"Exec state with init as starting state value and st."
((proc st) (list init init)))
|
