Clojure Typed Monad

typedmonad.clj

;;; Monad

(defprotocol [m] Monad
  ([a] return [ctx, v :- a] :- (m a))
  ([a b] bind [ctx, mv :- (m a), f :- [a -> (m b)]] :- (m b)))

(defalias TFn1 (TFn [[x :variance :covariant]] Any))


;;; Identity Monad

(ann-record IdentityMonad [] :extends [(Monad Id)])
(defrecord IdentityMonad []
  Monad
  (return [_ v] v)
  (bind [_ mv f] (f mv)))


;;; Maybe Types

(defprotocol [a] Maybe
  ([r] maybe-call [this, on-just :- [a -> r], on-nothing :- [-> r]] :- r))

(ann-record [a] MaybeJust [v :- a])
(defrecord MaybeJust [v]
  Maybe
  (maybe-call [this on-just on-nothing]
    (on-just v)))

(ann-record MaybeNothing [])
(defrecord MaybeNothing []
  Maybe
  (maybe-call [this on-just on-nothing]
    (on-nothing)))

(defmacro match-maybe [m just-bind just-expr nothing-bind nothing-expr]
  `(maybe-call ~m (fn ~just-bind ~just-expr) (fn ~nothing-bind ~nothing-expr)))


;;; Maybe Monad

(ann-record MaybeMonad [] :extends [(Monad Maybe)])
(defrecord MaybeMonad []
  Monad
  (return [_ v] (->MaybeJust v))
  (bind [_ mv f]
    (match-maybe mv
      [v :- a] (f v)
      [] (->MaybeNothing))))

(def maybe-m (->MaybeMonad))

(tc-ignore
  ;; TODO: Monad Transformer doesn't work
(ann-record [[m :< TFn1 :variance :covariant]]
            MaybeMonadT [m :- (Monad m)]
            :extends [(Monad (TFn [[x :variance :covariant]] (m (Maybe x))))])
(defrecord MaybeMonadT [m]
  Monad
  (return [_ v] (return m (->MaybeJust v)))
  (bind [_ mmv f]
    (bind m mmv
          (fn [mv]
            (match-maybe mv
              [v :- a] (f v)
              [] (return m (->MaybeNothing)))))))

(ann maybe-t (All [[m :< TFn1]] [(Monad m) -> (MaybeMonadT TFn1)]))
(defn maybe-t [m] (->MaybeMonadT m))


(ann double-maybe-m (MaybeMonadT Maybe))
(def double-maybe-m (maybe-t maybe-m)))


;;; Either Types

(defprotocol [x y] Either
  ([r] either-call [this, on-left :- [x -> r] , on-right :- [y -> r]] :- r))

(ann-record [x] EitherLeft [v :- x]
            :extends [(Either x Nothing)])
(defrecord EitherLeft [v]
  Either
  (either-call [this on-left on-right]
    (on-left v)))

(ann-record [y] EitherRight [v :- y]
            :extends [(Either Nothing y)])
(defrecord EitherRight [v]
  Either
  (either-call [this on-left on-right]
    (on-right v)))

(defmacro match-either [e left-bind left-expr right-bind right-expr]
  `(either-call ~e (fn ~left-bind ~left-expr) (fn ~right-bind ~right-expr)))


;;; Either Monad

(ann-record [[e :variance :covariant]]
            ErrorMonad []
            :extends [(Monad (TFn [[x :variance :invariant]]
                                  (Either e x)))])
(defrecord ErrorMonad []
  Monad
  (return [_ v] (->EitherRight v))
  (bind [_ mv f]
    (match-either mv
      [e :- e] (->EitherLeft e)
      [v :- a] (f v))))

(def error-m (->ErrorMonad))



;;; State Types

(defprotocol [[s :variance :covariant]
              [a :variance :covariant]] State
  (run-state [this s :- s] :- (HVec [a s])))

(ann-record [[s :variance :covariant]
             [a :variance :covariant]] StateReturn [v :- a]
            :extends [(State s a)])
(defrecord StateReturn [v]
  State
  (run-state [this s] [v s]))

(ann-record [s a b] StateBind [mv :- (State s a),
                               f :- [a -> (State s b)]]
            :extends [(State s b)])
(defrecord StateBind [mv f]
  State
  (run-state [this s]
    (let [[v ss] (run-state mv s)]
      (run-state (f v) ss))))


;;; State Monad

(ann-record [[s :variance :covariant]]
            StateMonad []
            :extends [(Monad (TFn [[x :variance :covariant]]
                                  (State s x)))])
(defrecord StateMonad []
  Monad
  (return [_ v] (->StateReturn v))
  (bind [_ mv f] (->StateBind mv f)))

(def state-m (->StateMonad))