blob: 97f4af61d0dffff5f6808789f89690c73809696f (
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
|
(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
fmap <$> cmap <*>
>> >>= return))
(define-generic return)
(define-method (return (a <top>)) identity)
(define-method (return (a <pair>)) list)
(define-generic >>=)
(define-method (>>= (a <top>) (proc <procedure>))
(proc a))
(define-method (>>= (this <null>) proc) '())
(define-method (>>= (this <pair>)
(proc <procedure>))
(concatenate! (map proc this)))
(define-generic >>)
(define-method (>> (a <top>) (b <top>))
(>>= a (lambda args b)))
(define-method (>> (a <null>) (b <null>)) '())
(define-method (>> (a <pair>) (b <null>)) '())
(define-method (>> (a <null>) (b <pair>)) '())
(define-method (>> (a <pair>) (b <pair>))
(concatenate! (map (const b) a)))
;; 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-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 (fmap f m)
(>>= m (lambda (x) ((return m) (f x)))))
(define <$> fmap)
;; Curried map
(define (cmap f)
(lambda (m) (fmap f m)))
(define (<*> f_ i_)
(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)))
|
