blob: 9d21b4cfbaa3988f159efb6b4b1be83a081bc72a (
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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
;;; Commentary:
;;
;; This is the base class of the monad interface.
;; It provides all the frames and glue required to use the library, and also
;; sets up the list monad (for multiple return values).
;;
;; To top it off, it gives default <top> definitions to return and bind (>>=),
;; meaning that they will sort of work with any type.
;;
;;; Code:
(define-module (monad)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 curried-definitions)
#:use-module (oop goops)
#:replace (do)
#:export (sequence
mapM return
<$> <*>
>> >>=))
(define-generic return)
;; We start by defining our primitive operations,
(define-method (return (a <top>))
"@code{return :: Monad m => a -> m a}
Since we can't directly defer type from context we instead allow @code{return}
to take an object of the desired type for @code{return}.
The default implementation is simple the identity function.
"
identity)
(define-generic >>=)
(define-method (>>= (a <top>) (proc <procedure>))
"@code{bind :: Monad m => m a x (a -> m b) -> m b}
Bind (or >>=) takes a monad value along with a procedure taking a regular value
and returning a monad value.
The default implementation simply applies proc to the value. Allowing any value
to be have the monadic type of being a scheme object.
"
(proc a))
(define-generic >>)
(define-method (>> (a <top>) (b <top>))
(>>= a (lambda args b)))
;;; ----------------------------------------
;;- We replace Scheme's built in @code{do} with our own, which works exactly like
;;- Haskell's do. @code{let} and @code{<-} included.
(define-syntax do
(syntax-rules (<- let =)
((_ let ptrn = val rest ...)
(match val
(ptrn (do rest ...))))
((_ ptrn <- val rest ...)
(>>= val (match-lambda (ptrn (do rest ...)))))
((_ a) a) ; Base case
((_ token rest ...)
(>> token (do rest ...)))))
;;; ----------------------------------------
(define (<$> f m_)
"@code{map :: Functor f => (a -> b) x f a -> f b}
@code{Fmap}; works on any monadic type since all monads are monoids in the
category of @emph{endofunctors}@footnote{What's the problem?}"
(>>= m_ (lambda (m) ((return m_) (f m)))))
(define (<*> f_ i_)
"@code{applicative :: Functor f => f (a -> b) x f a -> f b}"
(do f <- f_
i <- i_
((return f_) (f i))))
;;; ----------------------------------------
;; This makes all curly infix operators be left associative,
;; discarding regular order of operations.
;; It does however work in my below example where I do
;; > f <$> a <*> b
;; Which is all that really matters.
(define-syntax $nfx$
(syntax-rules ()
((_ single) single)
((_ a * b rest ...)
($nfx$ (* a b) rest ...))))
;; sequence :: (list (M a)) → M (list a)
(define (sequence in-list)
"Evaluate each monadic action in the structure from left to right, and collect
the results. For a version that ignores the results see sequence_.
https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
(define ((f done) item) (append done (list item)))
(fold (lambda (m-item m-done)
#!curly-infix { f <$> m-done <*> m-item })
;; TODO this fails on a list of length 0
((return (car in-list)) '())
in-list))
;; mapM :: (a -> M b) x (list a) → M (list b)
(define (mapM proc items)
"Map each element of a structure to a monadic action, evaluate these actions from
left to right, and collect the results. For a version that ignores the results
see mapM_.
https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
(sequence (map (lambda (x) (>>= x proc)) items)))
;;; ----------------------------------------
(define-method (return (a <pair>)) list)
(define-method (>>= (this <null>) proc) '())
(define-method (>>= (this <pair>)
(proc <procedure>))
(apply append (map proc this)))
|
