blob: d9745e9ab223e4c318f642f124b9cfb6e959d74a (
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
|
(ns lang.util
(:require [clojure.string :as string]
[clojure.core.match :refer [match]]))
;; [Interface]
;; [Interface/Utils]
(defn fail* [message]
[::failure message])
(defn return* [state value]
[::ok [state value]])
;; [Interface/Monads]
(defn fail [message]
(fn [_]
[::failure message]))
(defn return [value]
(fn [state]
[::ok [state value]]))
(defn bind [m-value step]
#(let [inputs (m-value %)]
;; (prn 'bind/inputs inputs)
(match inputs
[::ok [?state ?datum]]
((step ?datum) ?state)
[::failure _]
inputs)))
(defmacro exec [steps return]
(assert (not= 0 (count steps)) "The steps can't be empty!")
(assert (= 0 (rem (count steps) 2)) "The number of steps must be even!")
(reduce (fn [inner [label computation]]
(case label
:let `(let ~computation ~inner)
;; :when (assert false "Can't use :when")
:when `(if ~computation
~inner
zero)
;; else
`(bind ~computation (fn [~label] ~inner))))
return
(reverse (partition 2 steps))))
;; [Interface/Combinators]
(defn try-m [monad]
(fn [state]
(match (monad state)
[::ok [?state ?datum]]
(return* ?state ?datum)
[::failure _]
(return* state nil))))
(defn repeat-m [monad]
(fn [state]
(match (monad state)
[::ok [?state ?head]]
(do ;; (prn 'repeat-m/?state ?state)
(match ((repeat-m monad) ?state)
[::ok [?state* ?tail]]
(do ;; (prn 'repeat-m/?state* ?state*)
(return* ?state* (cons ?head ?tail)))))
[::failure ?message]
(do ;; (println "Failed at last:" ?message)
(return* state '())))))
(defn try-all-m [monads]
(fn [state]
(if (empty? monads)
(fail* "No alternative worked!")
(let [output ((first monads) state)]
(match output
[::ok _]
output
:else
(if-let [monads* (seq (rest monads))]
((try-all-m monads*) state)
output)
)))))
(defn map-m [f inputs]
(if (empty? inputs)
(return '())
(exec [output (f (first inputs))
outputs (map-m f (rest inputs))]
(return (conj outputs output)))))
(defn apply-m [monad call-state]
(fn [state]
;; (prn 'apply-m monad call-state)
(let [output (monad call-state)]
;; (prn 'apply-m/output output)
(match output
[::ok [?state ?datum]]
[::ok [state ?datum]]
[::failure _]
output))))
(defn comp-m [f-m g-m]
(exec [temp g-m]
(f-m temp)))
(defn pass [m-value]
(fn [state]
m-value))
(def get-state
(fn [state]
(return* state state)))
|
