scratch.clj

(ns net.gensoukyou.monad-protocol)

(declare *current-monad*)

(defprotocol Monad
  (pure-impl [M v] "Lift a value into the same monad as M")
  (bind [mv f]))

(defprotocol MonadPlus
  (++ [mv1 mv1])
  (zero-impl [mv]))

(defn mzero [] (zero-impl *current-monad*))

(defn pure [v]
  (pure-impl *current-monad* v))

(defn lift
  "I can't believe this works" 
  ([f]
     (fn this
       ([v v2 & rest]
          (bind (this v v2) (fn [x] (apply this (pure x) rest))))
       ([v v2]
          (bind v (fn [x] (bind v2 (partial (comp pure f) x)))))
       ([v]
          (bind v (comp pure f))))))

(defmacro with-monad [monad & body]
  `(binding [*current-monad* ~monad]
    ~@body))


(deftype MaybeM [val] :as this
  Monad
  (pure-impl [v] (MaybeM. v))
  (bind [mf] (if-let [v (:val this)]
              (mf v)
              this))
  MonadPlus
  (++ [mv2] (if (:val this)
              this
              mv2))
  (zero-impl [] (MaybeM. nil)))

(def Maybe (MaybeM nil)) ;; for use in with-monad

(extend-type clojure.lang.ISeq
             Monad
             (pure-impl [M v] (list v))
             (bind [mv mf]
                   (mapcat mf mv)))


(with-monad Maybe
  (bind (pure 4) (comp pure inc)))

(with-monad ()
  (bind (seq [1 2 3])
        (fn [x]
          (bind (seq [1 2 3])
                (fn [y] (pure (+ x y)))))))

(with-monad Maybe
  ((lift +) (MaybeM 5) (MaybeM 3) (MaybeM 3) (MaybeM 4) (MaybeM 22)))

(with-monad ()
  ((lift +) '(1 2) '(3 4 5)))