smalltalk-tng

view experiments/monad/general-monad.scm @ 88:9e14ff21779b

find changesets by author, revision, files, or words in the commit message
Oops - of course we need srfi-1 for append-map!
author Tony Garnock-Jones <tonyg@lshift.net>
date Fri May 12 05:09:25 2006 +1200 (2006-05-12)
parents a2bf6705afa2
children 7254de0e9cb5
line source
1 (require (lib "match.ss")
2 (lib "etc.ss")
3 (lib "errortrace.ss" "errortrace")
4 (lib "1.ss" "srfi")
5 (lib "9.ss" "srfi"))
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8
9 (print-struct #t)
10 (define previous-inspector (current-inspector))
11 (current-inspector (make-inspector))
12
13 (define-record-type <monad-class>
14 (make-monad-class name binder returner failer)
15 monad-class?
16 (name monad-class-name)
17 (binder monad-class-binder)
18 (returner monad-class-returner)
19 (failer monad-class-failer))
20
21 (define-record-type <monad>
22 (make-monad kind value)
23 monad?
24 (kind monad-kind)
25 (value monad-value))
26
27 (current-inspector previous-inspector)
28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30
31 (define (determined? m)
32 (monad-class? (monad-kind m)))
33
34 (define (monadize m)
35 (cond
36 ((pair? m) (make-monad *list* m))
37 ((null? m) (make-monad *list* m))
38 ((monad? m) (if (eq? (monad-kind m) '_delayed)
39 ((monad-value m))
40 m))
41 (else (error "not a monad" m))))
42
43 (define-syntax delay-monad
44 (syntax-rules ()
45 ((_ m) (delay-monad* (lambda () (undelay-monad m))))))
46
47 (define (delay-monad* m)
48 (make-monad '_delayed m))
49
50 (define (undelay-monad m)
51 (if (and (monad? m) (eq? (monad-kind m) '_delayed))
52 ((monad-value m))
53 m))
54
55 (define (>>= ma a->mb)
56 (let ((ma (monadize ma)))
57 (if (determined? ma)
58 ((monad-class-binder (monad-kind ma)) ma a->mb)
59 (make-monad '_bind (list ma a->mb)))))
60
61 (define (return a)
62 (make-monad '_return a))
63
64 (define (fail s)
65 (make-monad '_fail s))
66
67 (define-syntax mlet*
68 (syntax-rules ()
69 ((_ () mexpN) mexpN)
70 ((_ ((var mexp) rest ...) mexpN)
71 (>>= mexp (lambda (var) (mlet* (rest ...) mexpN))))))
72
73 (define (wrong-mclass mclass m)
74 (error "wrong monad-class" `((mclass ,mclass) (m ,m))))
75
76 (define (determine mclass m)
77 (let continue ((m m))
78 (let* ((m (monadize m))
79 (kind (monad-kind m)))
80 (if (determined? m)
81 (if (eq? kind mclass)
82 m
83 (wrong-mclass mclass m))
84 (continue
85 (case kind
86 ((_bind) ((monad-class-binder mclass)
87 (continue (car (monad-value m)))
88 (cadr (monad-value m))))
89 ((_return) ((monad-class-returner mclass) (monad-value m)))
90 ((_fail) ((monad-class-failer mclass) (monad-value m)))
91 (else
92 (error "invalid monad-kind" m))))))))
93
94 (define (monad-arg mclass)
95 (lambda (m) (monad-value (determine mclass m))))
96
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
98
99 (define *list* (make-monad-class 'list
100 (lambda (L f) (append-map (compose run-list f) (run-list L)))
101 (lambda (x) (list x))
102 (lambda (s) '())))
103
104 (define run-list (monad-arg *list*))
105
106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107
108 (define *io* (make-monad-class 'io
109 (lambda (io1 f) (delay-monad (f (run-io io1))))
110 (lambda (v) (make-monad *io* (lambda () v)))
111 error))
112
113 (define io-action (monad-arg *io*))
114
115 (define (run-io m)
116 ((io-action m)))
117
118 (define (mdisplay x)
119 (make-monad *io* (lambda () (display x) 'done)))
120
121 (define mread
122 (make-monad *io* (lambda () (read))))
123
124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125
126 (define *state* (make-monad-class 'state
127 (lambda (st1 f)
128 (make-monad *state*
129 (lambda (s0)
130 (let* ((inp (run-st st1 s0))
131 (v (car inp))
132 (s1 (cdr inp)))
133 (run-st (f v) s1)))))
134 (lambda (a)
135 (make-monad *state*
136 (lambda (s0) (cons a s0))))
137 error))
138
139 (define state-xformer (monad-arg *state*))
140
141 (define (run-st m initial)
142 ((state-xformer m) initial))
143
144 (define sget
145 (make-monad *state* (lambda (s0) (cons s0 s0))))
146
147 (define (sput a)
148 (make-monad *state* (lambda (s0) (cons 'unit a))))
149
150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151
152 (define (mixed-monad-demo)
153 (run-io (mlet* ((_ (mdisplay "Enter a number\n"))
154 (n mread)
155 (all-n (return (iota n)))
156 (_ (mdisplay "Numbers: "))
157 (_ (mdisplay all-n))
158 (_ (mdisplay "\n")))
159 (return 'nothing))))
160
161 (define oleg-example-mixed-monad
162 (mlet* ((_ (mdisplay "Enter a number: "))
163 (n mread)
164 (all-n (return (iota n)))
165 (evens (return (run-list (mlet* ((i all-n))
166 (if (even? i)
167 (return i)
168 (fail "odd"))))))
169 (_ (mdisplay "Computed "))
170 (_ (mdisplay (length evens)))
171 (_ (mdisplay " evens\n")))
172 (return evens)))