Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added code

  • Loading branch information...
commit 355dacac08778e9f8ca81086cd3d17bf62e7193c 1 parent 8bb498f
Jim Duey authored
Showing with 356 additions and 0 deletions.
  1. +3 −0  project.clj
  2. +197 −0 src/monads2/core.clj
  3. +156 −0 test/monads2/test/core.clj
View
3  project.clj
@@ -0,0 +1,3 @@
+(defproject monads2 "1.0.0-SNAPSHOT"
+ :description "A protocol based implementation of monads"
+ :dependencies [[org.clojure/clojure "1.3.0"]])
View
197 src/monads2/core.clj
@@ -0,0 +1,197 @@
+(ns monads2.core
+ (:refer-clojure :exclude [do seq])
+ (:require [clojure.set :as set]))
+
+(defprotocol Monad
+ (do-result [_ v])
+ (bind [mv f]))
+
+(defprotocol MonadZero
+ (zero [_])
+ (plus-step [mv mvs]))
+
+(defn plus [[mv & mvs]]
+ (plus-step mv mvs))
+
+(defmacro do [bindings expr]
+ (let [steps (reverse (partition 2 bindings))
+ example (->> steps
+ (remove (comp keyword? first))
+ first
+ second)]
+ (reduce (fn [expr [sym mv]]
+ (cond
+ (= :when sym) `(if ~mv
+ ~expr
+ (monads2.core/zero ~example))
+ (= :let sym) `(let ~mv
+ ~expr)
+ :else `(monads2.core/bind ~mv (fn [~sym]
+ ~expr))))
+ `(monads2.core/do-result ~example ~expr)
+ steps)))
+
+(defmacro seq [mvs]
+ (let [steps (map (fn [x]
+ (let [sym (gensym)]
+ [sym x]))
+ mvs)
+ syms (map first steps)]
+ `(monads2.core/do [~@(apply concat steps)] [~@syms])))
+
+
+(extend-type clojure.lang.PersistentList
+ Monad
+ (do-result [_ v]
+ (list v))
+ (bind [mv f]
+ (mapcat f mv))
+
+ MonadZero
+ (zero [_]
+ (list))
+ (plus-step [mv mvs]
+ (apply concat mv mvs)))
+
+(extend-type clojure.lang.PersistentList$EmptyList
+ Monad
+ (do-result [_ v]
+ (list v))
+ (bind [mv f]
+ (mapcat f mv))
+
+ MonadZero
+ (zero [_]
+ (list))
+ (plus-step [mv mvs]
+ (apply concat mv mvs)))
+
+(extend-type clojure.lang.PersistentVector
+ Monad
+ (do-result [_ v]
+ [v])
+ (bind [mv f]
+ (vec (mapcat f mv)))
+
+ MonadZero
+ (zero [_]
+ [])
+ (plus-step [mv mvs]
+ (vec (apply concat mv mvs))))
+
+(extend-type clojure.lang.LazySeq
+ Monad
+ (do-result [_ v]
+ (list v))
+ (bind [mv f]
+ (mapcat f mv))
+
+ MonadZero
+ (zero [_]
+ [])
+ (plus-step [mv mvs]
+ ; TODO: make lazy
+ (apply concat mv mvs)))
+
+(extend-type clojure.lang.PersistentHashSet
+ Monad
+ (do-result [_ v]
+ (hash-set v))
+ (bind [mv f]
+ (apply set/union
+ (map f mv)))
+
+ MonadZero
+ (zero [_]
+ #{})
+ (plus-step [mv mvs]
+ (apply set/union mv mvs)))
+
+
+(declare state)
+
+(deftype state-binder [mv f]
+ clojure.lang.IFn
+ (invoke [_ s]
+ (let [[v ss] (mv s)]
+ ((f v) ss)))
+
+ Monad
+ (do-result [_ v]
+ (state v))
+ (bind [mv f]
+ (state-binder. mv f)))
+
+(deftype state-monad [v]
+ clojure.lang.IFn
+ (invoke [_ s]
+ [v s])
+
+ Monad
+ (do-result [_ v]
+ (state v))
+ (bind [mv f]
+ (state-binder. mv f)))
+
+(defn state [v]
+ (state-monad. v))
+
+(defn update-state [f]
+ (reify
+ clojure.lang.IFn
+ (invoke [_ s]
+ [s (f s)])
+
+ Monad
+ (do-result [_ v]
+ (state v))
+ (bind [mv f]
+ (state-binder. mv f))))
+
+(defn set-state [s]
+ (update-state (constantly s)))
+
+(defn get-state []
+ (update-state identity))
+
+(defn get-val [key]
+ (monads2.core/do
+ [s (get-state)]
+ (get s key)))
+
+(defn update-val [key f & args]
+ (monads2.core/do
+ [s (update-state #(apply update-in % [key] f args))]
+ (get s key)))
+
+(defn set-val [key val]
+ (update-val key (constantly val)))
+
+
+(declare cont)
+
+(deftype cont-binder [mv f]
+ clojure.lang.IFn
+ (invoke [_ c]
+ (mv (fn [v] ((f v) c))))
+
+ Monad
+ (do-result [_ v]
+ (cont v))
+ (bind [mv f]
+ (cont-binder. mv f)))
+
+(deftype cont-monad [v]
+ clojure.lang.IFn
+ (invoke [_ c]
+ (c v))
+
+ Monad
+ (do-result [_ v]
+ (cont-monad. v))
+ (bind [mv f]
+ (cont-binder. mv f)))
+
+(defn cont [v]
+ (cont-monad. v))
+
View
156 test/monads2/test/core.clj
@@ -0,0 +1,156 @@
+(ns monads2.test.core
+ (:use [clojure.test])
+ (:require [monads2.core :as m]))
+
+(defn list-f [n]
+ (list (inc n)))
+
+(defn list-g [n]
+ (list (+ n 5)))
+
+(deftest first-law-list
+ (is (= (m/bind (list 10) list-f)
+ (list-f 10))))
+
+(deftest second-law-list
+ (is (= (m/bind '(10) list)
+ '(10))))
+
+(deftest third-law-list
+ (is (= (m/bind (m/bind [4 9] list-f) list-g)
+ (m/bind [4 9] (fn [x]
+ (m/bind (list-f x) list-g))))))
+
+(deftest zero-law-list
+ (is (= (m/bind '() list-f)
+ '()))
+ (is (= (m/bind '(4) (constantly '()))
+ '()))
+ (is (= (m/plus [(list 5 6) '()])
+ (list 5 6)))
+ (is (= (m/plus ['() (list 5 6)])
+ (list 5 6))))
+
+
+(defn vector-f [n]
+ (vector (inc n)))
+
+(defn vector-g [n]
+ (vector (+ n 5)))
+
+(deftest first-law-vector
+ (is (= (m/bind [10] vector-f)
+ (vector-f 10))))
+
+(deftest second-law-vector
+ (is (= (m/bind [10] vector)
+ [10])))
+
+(deftest third-law-vector
+ (is (= (m/bind (m/bind [4 9] vector-f) vector-g)
+ (m/bind [4 9] (fn [x]
+ (m/bind (vector-f x) vector-g))))))
+
+(deftest zero-law-vector
+ (is (= (m/bind [] vector-f)
+ []))
+ (is (= (m/bind '(4) (constantly []))
+ []))
+ (is (= (m/plus [(vector 5 6) []])
+ (vector 5 6)))
+ (is (= (m/plus [[] (vector 5 6)])
+ (vector 5 6))))
+
+
+(defn set-f [n]
+ (hash-set (inc n)))
+
+(defn set-g [n]
+ (hash-set (+ n 5)))
+
+(deftest first-law-set
+ (is (= (m/bind #{10} set-f)
+ (set-f 10))))
+
+(deftest second-law-set
+ (is (= (m/bind #{10} hash-set)
+ #{10})))
+
+(deftest third-law-set
+ (is (= (m/bind (m/bind #{4 9} set-f) set-g)
+ (m/bind #{4 9} (fn [x]
+ (m/bind (set-f x) set-g))))))
+
+(deftest zero-law-set
+ (is (= (m/bind #{} set-f)
+ #{}))
+ (is (= (m/bind #{4} (constantly #{}))
+ #{}))
+ (is (= (m/plus [(hash-set 5 6) #{}])
+ (hash-set 5 6)))
+ (is (= (m/plus [#{} (hash-set 5 6)])
+ (hash-set 5 6))))
+
+
+(defn state-f [n]
+ (m/state (inc n)))
+
+(defn state-g [n]
+ (m/state (+ n 5)))
+
+(deftest first-law-state
+ (let [mv1 (m/bind (m/state 10) state-f)
+ mv2 (state-f 10)]
+ (is (= (mv1 {}) (mv2 {})))))
+
+(deftest second-law-state
+ (let [mv1 (m/bind (m/state 10) m/state)
+ mv2 (m/state 10)]
+ (is (= (mv1 :state) (mv2 :state)))))
+
+(deftest third-law-state
+ (let [mv1 (m/bind (m/bind (m/state 4) state-f) state-g)
+ mv2 (m/bind (m/state 4)
+ (fn [x]
+ (m/bind (state-f x) state-g)))]
+ (is (= (mv1 :state) (mv2 :state)))))
+
+(deftest test-update-state
+ (is (= [:state :new-state]
+ ((m/update-state (constantly :new-state)) :state))))
+
+(deftest test-update-val
+ (is (= [5 {:a 19}]
+ ((m/update-val :a + 14) {:a 5}))))
+
+
+(defn cont-f [n]
+ (m/cont (inc n)))
+
+(defn cont-g [n]
+ (m/cont (+ n 5)))
+
+(deftest first-law-cont
+ (let [mv1 (m/bind (m/cont 10) cont-f)
+ mv2 (cont-f 10)]
+ (is (= (mv1 identity) (mv2 identity)))))
+
+(deftest second-law-cont
+ (let [mv1 (m/bind (m/cont 10) m/cont)
+ mv2 (m/cont 10)]
+ (is (= (mv1 identity) (mv2 identity)))))
+
+(deftest third-law-cont
+ (let [mv1 (m/bind (m/bind (m/cont 4) cont-f) cont-g)
+ mv2 (m/bind (m/cont 4)
+ (fn [x]
+ (m/bind (cont-f x) cont-g)))]
+ (is (= (mv1 identity) (mv2 identity)))))
+
+
+#_(prn :do ((m/do
+ [x (m/state 29)
+ y (m/state 12)
+ :let [z (inc x)]]
+ [x y z])
+ :state))
Please sign in to comment.
Something went wrong with that request. Please try again.