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) m)

39 (else (error "not a monad" m))))

40

41 (define (>>= ma a->mb)

42 (let ((ma (monadize ma)))

43 (if (determined? ma)

44 ((monad-class-binder (monad-kind ma)) ma a->mb)

45 (make-monad '_bind (list ma a->mb)))))

46

47 (define (return a)

48 (make-monad '_return a))

49

50 (define (fail s)

51 (make-monad '_fail s))

52

53 (define-syntax mlet*

54 (syntax-rules ()

55 ((_ () mexpN) mexpN)

56 ((_ ((var mexp) rest ...) mexpN)

57 (>>= mexp (lambda (var) (mlet* (rest ...) mexpN))))))

58

59 (define (wrong-mclass mclass m)

60 (error "wrong monad-class" `((mclass ,mclass) (m ,m))))

61

62 (define (determine mclass m)

63 (let continue ((m m))

64 (let* ((m (monadize m))

65 (kind (monad-kind m)))

66 (if (determined? m)

67 (if (eq? kind mclass)

68 m

69 (wrong-mclass mclass m))

70 (continue

71 (case kind

72 ((_bind) ((monad-class-binder mclass)

73 (continue (car (monad-value m)))

74 (cadr (monad-value m))))

75 ((_return) ((monad-class-returner mclass) (monad-value m)))

76 ((_fail) ((monad-class-failer mclass) (monad-value m)))

77 (else

78 (error "invalid monad-kind" m))))))))

79

80 (define (monad-arg mclass)

81 (lambda (m) (monad-value (determine mclass m))))

82

83 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

84

85 (define *list* (make-monad-class 'list

86 (lambda (L f) (append-map (compose run-list f) (run-list L)))

87 (lambda (x) (list x))

88 (lambda (s) '())))

89

90 (define run-list (monad-arg *list*))

91

92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

93

94 (define *io* (make-monad-class 'io

95 (lambda (io1 f) (make-monad *io* (cons (io-action io1) f)))

96 (lambda (v) (make-monad *io* (lambda () v)))

97 error))

98

99 (define io-action (monad-arg *io*))

100

101 (define (run-io m)

102 (let run-action ((action (io-action m)))

103 (if (pair? action)

104 (let ((previous-action (car action))

105 (continuation (cdr action)))

106 (run-io (continuation (run-action previous-action))))

107 (action))))

108

109 (define (mdisplay x)

110 (make-monad *io* (lambda () (display x) 'done)))

111

112 (define mread

113 (make-monad *io* (lambda () (read))))

114

115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

116

117 (define *state* (make-monad-class 'state

118 (lambda (st1 f)

119 (make-monad *state*

120 (lambda (s0)

121 (let* ((inp (run-st st1 s0))

122 (v (car inp))

123 (s1 (cdr inp)))

124 (run-st (f v) s1)))))

125 (lambda (a)

126 (make-monad *state*

127 (lambda (s0) (cons a s0))))

128 error))

129

130 (define state-xformer (monad-arg *state*))

131

132 (define (run-st m initial)

133 ((state-xformer m) initial))

134

135 (define sget

136 (make-monad *state* (lambda (s0) (cons s0 s0))))

137

138 (define (sput a)

139 (make-monad *state* (lambda (s0) (cons 'unit a))))

140

141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

142

143 (define (mixed-monad-demo)

144 (run-io (mlet* ((_ (mdisplay "Enter a number\n"))

145 (n mread)

146 (all-n (return (iota n)))

147 (_ (mdisplay "Numbers: "))

148 (_ (mdisplay all-n))

149 (_ (mdisplay "\n")))

150 (return 'nothing))))

151

152 (define oleg-example-mixed-monad

153 (mlet* ((_ (mdisplay "Enter a number: "))

154 (n mread)

155 (all-n (return (iota n)))

156 (evens (return (run-list (mlet* ((i all-n))

157 (if (even? i)

158 (return i)

159 (fail "odd"))))))

160 (_ (mdisplay "Computed "))

161 (_ (mdisplay (length evens)))

162 (_ (mdisplay " evens\n")))

163 (return evens)))