blob: d8d96e3352d9355a1e0bb9762a6e67ce277ebe8f (
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
|
runState (return "X") 1
=> ("X", 1)
;;; return set the result value but leave the state unchanged
(read-enable 'curly-infix)
(use-modules (oop goops)
(oop goops describe)
(ice-9 match)
(srfi srfi-1))
(define-generic bind)
(define-generic return)
(define-class <optional> ()
(slot #:init-value #f
#:init-keyword #:slot)
(just #:init-value #t
#:init-keyword #:just))
(define (nothing) (make <optional> #:just #f))
(define (just obj) (make <optional>
#:just #t
#:slot obj))
(define (nothing? this)
(not (slot-ref this 'just)))
(define (just? this)
(not (nothing? this)))
(define-method (write (this <optional>) port)
(if (just? this)
(format port "[Just ~s]" (slot-ref this 'slot))
(format port "[Nothing]")))
;; bind :: Monad m => m a -> (a -> m b) -> m b
;; return :: Monad m => a -> m a
;; map :: Functor f => (a -> b) -> f a -> f b
(define-method (>>= (this <optional>)
(proc <procedure>))
(cond ((nothing? this) (nothing))
((just? this)
(match this
(($ <optional> slot) (proc slot))))))
(define-method (>>= (this <null>)
proc)
'())
(define-method (>>= (this <pair>)
(proc <procedure>))
(concatenate! (map proc this)))
(define-syntax do
(syntax-rules (<- let =)
((_ let var = val rest ...)
(let ((var val)) (do rest ...)))
((_ ptrn <- val rest ...)
(<- ptrn val rest ...))
((_ a) a)
((_ token rest ...)
(begin token (do rest ...)))))
(define-syntax <-
(lambda (x)
(syntax-case x (just)
((_ (just var) val rest ...)
#'(>>= val (lambda (var) rest ...))))))
;;; Examples:
(do (just x) <- (just 10)
x) ; => 10
(do let y = (just 10)
(just x) <- y
(+ x 5)) ; => 15
(do (just x) <- (nothing)
(+ x 5)) ; => [Nothing]
|