Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(ns user
(:use clojure.set))
;; core
(defstruct monad :unit :bind :run :zero :plus)
(defmacro defmonad [name & fdecl]
(let [[doc defs]
(if (string? (first fdecl))
[(first fdecl) (rest fdecl)]
[nil fdecl])]
`(def ~(with-meta name (into (or (meta name) {}) (if doc {:doc doc} {})))
(struct-map monad ~@defs))))
;; generic dispatchers
(defstruct forall-dispatcher :forall)
(defmacro forall [[t] x]
`(struct forall-dispatcher (fn [~t] ~x)))
(defn at [m x]
(if-let [f (and (map? x) (:forall x))]
(f m)
(defn unit [x]
(forall [t] ((:unit t) x)))
(defn bind [m f]
(forall [t] ((:bind t) (at t m) (fn [x] (at t (f x))))))
(defn run [t & xs]
(let [m (last xs)
xs (butlast xs)]
(apply (:run t) (concat xs [(at t m)]))))
(defn zero []
(forall [t] (:zero t)))
(defn plus [m1 m2]
(forall [t] ((:plus t) (at t m1) (at t m2))))
;; helpers
(defmacro >>= [& body]
(reduce (fn [x y]
(let [[v m] (if (vector? y) y ['% y])]
`(bind ~m (fn [~v] ~x))))
(last body)
(reverse (butlast body))))
(defmacro >> [& body]
`(>>= ~@(butlast body) (unit ~(last body))))
(defn either [& ms]
(reduce #(plus %2 %1) (reverse ms)))
(defn mfilter [mpred coll]
(if (seq coll)
(>> [b (mpred (first coll))]
[xs (mfilter mpred (rest coll))]
(if b
(lazy-seq (cons (first coll) xs))
(>> ())))
;; monad implementations
(defmonad identity-monad
"The identity monad"
:unit identity
:bind (fn [m f] (f m))
:run identity)
(def run-identity (partial run identity-monad))
(defmonad maybe-monad
"The maybe/option monad."
:unit identity
:bind (fn [m f] (when-not (nil? m) (f m)))
:zero nil
:plus (fn [m1 m2] (if (nil? m1) m2 m1))
:run identity)
(def run-maybe (partial run maybe-monad))
(defn flip [f]
(fn [x y] (f y x)))
(defmonad seq-monad
"The sequence monad."
:unit list
:bind (flip mapcat)
:zero ()
:plus concat
:run identity)
(def run-seq (partial run seq-monad))
(defmonad set-monad
"The set monad."
:unit (fn [x] #{x})
:bind (fn [m f] (apply union (map f m)))
:zero #{}
:plus union
:run identity)
(def run-set (partial run set-monad))
(defmonad state-monad
"The state monad."
:unit (fn [x] (fn [s] [x s]))
:bind (fn [m f] (fn [s]
(let [[x s-new] (m s)]
((f x) s-new))))
:run (fn [s m] (m s)))
(def run-state (partial run state-monad))
(def get-state (fn [s] [s s]))
(defn set-state [x] (fn [s] [nil x]))
(defn update-state [f] (fn [s] [s (f s)]))
;; examples
(>> [x (range 100)]
[y (range 100)]
(+ x y)))
(>> [x (>> [y (range 100)] (* y y))]
(+ x x)))
(>> [x (either (unit 1) (unit 2) (unit 3))]
(* x x)))
(defn const [x]
(fn [& _] x))
(run-seq (mfilter (const [false true]) [1 2 3 4]))
(>> [x (range 100)]
[y (range 100)]
(+ x y)))
(run-state 100
(>> [x get-state]
(set-state 42)
[y (update-state #(+ % 8))]
[z get-state]
[x y z]))
(run-state 0 (mfilter (fn [x] (>> (update-state inc) (= (mod % 5) 0))) (range 100)))
(let [xs [1 2]]
(>> [x (first xs)]
[y (second xs)]
(+ x y))))
(let [xs [1]]
(>> [x (first xs)]
[y (second xs)]
(+ x y))))
(run-identity (>>= 42 (- % 2) (* % %)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment