モナドのサンプル１

monad_sample1.clj

(ns testmonad.core)


;;; Typeclass Protocols

(defprotocol Functor
  (fmap [mv f] "f : a -> b, mv : m a, fmap f mv : m b"))

(defprotocol Applicative
  (ap [mf mv] "mf : m (a -> b), mv : m a, ap mf mv : m b"))

(defprotocol Monoid
  (mempty [_] "mempty : m a") ;; need example instance for protocol
  (mappend [mv0 mv1] "mv0, mv1 : m a, mappend mv0 mv1 : m a"))

(defprotocol Monad
  (return [_ v] "v : a, return v : m a") ;; need example instance for protocol
  (bind [mv f] "mv : m a, f : a -> m b, bind mv f : m b"))





;;; Maybe

(defprotocol Maybe
  (maybe-call [obj on-just on-nothing]))

(defrecord Just [v]
  Maybe
  (maybe-call [obj on-just on-nothing]
    (on-just v)))

(defrecord Nothing []
  Maybe
  (maybe-call [obj on-just on-nothing]
    (on-nothing)))

(defmacro maybe 
  [obj just-sym just-expr nothing-expr]
  `(maybe-call
     ~obj
     (fn [~just-sym] ~just-expr)
     (fn [] ~nothing-expr)))

(def maybe-xi (->Nothing)) ;; example instance

(extend-type Just
  Functor
  (fmap [mv f] (->Just (f (:v mv))))
  Applicative
  (ap [mf mv]
    (maybe mv v
      (->Just ((:v mf) v))
      (->Nothing)))
  Monoid
  (mempty [_] (->Nothing))
  (mappend [mv0 mv1]
    (->Just (:v mv0)))
  Monad
  (return [_ v] (->Just v))
  (bind [mv f] (f (:v mv))))

(extend-type Nothing
  Functor
  (fmap [mv f] (->Nothing))
  Applicative
  (ap [mf mv] (->Nothing))
  Monoid
  (mempty [_] (->Nothing))
  (mappend [mv0 mv1]
    (maybe mv1 v1
      (->Just v1)
      (->Nothing)))
  Monad
  (return [_ v] (->Just v))
  (bind [mv f] (->Nothing)))




;;; List and LazySeq


(extend-type clojure.lang.ISeq
  Functor
  (fmap [mv f] (for [v mv] (f mv)))

  Applicative
  (ap [mf mv]
    (for [f mf v mv] (f v)))

  Monoid
  (mempty [_] (list))
  (mappend [mv0 mv1]
    (concat mv0 mv1))

  Monad
  (return [_ v] (list v))
  (bind [mv f] (for [v mv r (f v)] r)))

(def seq-xi []) ;; example instance
(defn return-seq [v] (return seq-xi v))
(defn mempty-seq [v] (mempty seq-xi))

;;; State

(defprotocol State
  (run-state [_ s]))

(declare ->StateBind)

(defrecord StateReturn [v]
  State
  (run-state [_ s] [v s])
  Monad
  (return [_ v] (->StateReturn v))
  (bind [mv f] (->StateBind mv f)))

(defrecord StateBind [mv f]
  State
  (run-state [_ s]
    (let [[v ss] (run-state mv s)]
      (run-state (f v) ss)))
  Monad
  (return [_ v] (->StateReturn v))
  (bind [mv f] (->StateBind mv f)))

(def state-xi (->StateReturn nil))
(defn return-state [v] (return state-xi v))