blob: b5552f98731ce5eaf7f60eeddaca5989c03dc91a (
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
|
## Copyright (c) Eduardo Julian. All rights reserved.
## The use and distribution terms for this software are covered by the
## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
## which can be found in the file epl-v10.html at the root of this distribution.
## By using this software in any fashion, you are agreeing to be bound by
## the terms of this license.
## You must not remove this notice, or any other, from this software.
(;import lux
(.. (functor #as F)
(monoid #as M))
lux/meta/macro)
## [Utils]
(def (foldL f init xs)
(All [a b]
(-> (-> a b a) a (List b) a))
(case xs
#;Nil
init
(#;Cons [x xs'])
(foldL f (f init x) xs')))
(def (reverse xs)
(All [a]
(-> (List a) (List a)))
(foldL (lambda [tail head] (#;Cons [head tail]))
#;Nil
xs))
(def (as-pairs xs)
(All [a] (-> (List a) (List (, a a))))
(case xs
(#;Cons [x1 (#;Cons [x2 xs'])])
(#;Cons [[x1 x2] (as-pairs xs')])
_
#;Nil))
## [Signatures]
(defsig #export (Monad m)
(: (F;Functor m)
_functor)
(: (All [a]
(-> a (m a)))
wrap)
(: (All [a]
(-> (m (m a)) (m a)))
join))
## [Syntax]
(defmacro #export (do tokens state)
(case tokens
## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
(#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])])
(let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
(lambda [body' binding]
(let [[var value] binding]
(case var
(#;Meta [_ (#;TagS ["" "let"])])
(` (;let (~ value) (~ body')))
_
(` (;case ;;_functor
{#F;map F;map}
(;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join))))
## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
))))
body
(reverse (as-pairs bindings)))]
(#;Right [state (#;Cons [(` (;case (~ monad)
{#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join}
(~ body')))
#;Nil])]))
_
(#;Left "Wrong syntax for do")))
## [Functions]
(def #export (bind m f ma)
(All [m a b]
(-> (Monad m) (-> a (m b)) (m a) (m b)))
(using m
(;;join (:: ;;_functor (F;map f ma)))))
(def #export (map% m f xs)
(All [m a b]
(-> (Monad m) (-> a (m b)) (List a) (m (List b))))
(case xs
#;Nil
(:: m (;;wrap #;Nil))
(#;Cons [x xs'])
(do m
[y (f x)
ys (map% m f xs')]
(;;wrap (#;Cons [y ys])))
))
|
