blob: 8be72c21baccca8f9b739dd50dfc7331da13911c (
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
|
(define-module (monad writer)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (monad monoid) ; ?
#:use-module (monad)
#:export (writer return-writer))
(read-enable 'curly-infix)
(define-class <writer> ()
(value #:init-keyword #:value)
(monoid #:init-keyword #:monoid))
(define (writer value context)
(make <writer>
#:value value
#:monoid context))
(define-method (>>= (this <writer>)
(proc <procedure>))
(match this (($ <writer> value monoid)
(match (proc value)
(($ <writer> nval ncontext)
(writer nval { monoid <> ncontext }))))))
(define-method (>> (a <writer>)
(b <writer>))
(match a (($ <writer> _ monoid-a)
(match b (($ <writer> val monoid-b)
(writer val (<> monoid-a monoid-b))
)))))
;;; TODO replace this
(define (return-writer val)
(writer val ""))
(define-method (write (this <writer>) port)
(match this (($ <writer> value monoid)
(format port "[Writer ~s, ~s]" value monoid))))
|
