{-
This module could also be part of 'transformers'.
-}
module UniqueLogic.ST.MonadTrans where

import qualified Control.Monad.Exception.Synchronous as E

import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.Maybe as MM
import qualified Control.Monad.Trans.Identity as MI

import Control.Applicative (Applicative, pure, (<*>), Const(Const))
import Control.Monad (liftM, ap, )
import Data.Monoid (Monoid, )


{- |
Provide the methods that make a transformed monad a monad.
-}
class MT.MonadTrans t => C t where
   point :: Monad m => a -> t m a
   bind :: Monad m => t m a -> (a -> t m b) -> t m b

instance C MI.IdentityT where
   point :: forall (m :: * -> *) a. Monad m => a -> IdentityT m a
point = forall (m :: * -> *) a. Monad m => a -> m a
return
   bind :: forall (m :: * -> *) a b.
Monad m =>
IdentityT m a -> (a -> IdentityT m b) -> IdentityT m b
bind = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)

instance (Monoid w) => C (MW.WriterT w) where
   point :: forall (m :: * -> *) a. Monad m => a -> WriterT w m a
point = forall (m :: * -> *) a. Monad m => a -> m a
return
   bind :: forall (m :: * -> *) a b.
Monad m =>
WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
bind = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)

instance C (E.ExceptionalT e) where
   point :: forall (m :: * -> *) a. Monad m => a -> ExceptionalT e m a
point = forall (m :: * -> *) a. Monad m => a -> m a
return
   bind :: forall (m :: * -> *) a b.
Monad m =>
ExceptionalT e m a
-> (a -> ExceptionalT e m b) -> ExceptionalT e m b
bind = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)

instance C MM.MaybeT where
   point :: forall (m :: * -> *) a. Monad m => a -> MaybeT m a
point = forall (m :: * -> *) a. Monad m => a -> m a
return
   bind :: forall (m :: * -> *) a b.
Monad m =>
MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
bind = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)


{- |
Build a regular monad for generic monad transformer and monad.
The 'Const' type allows us to force the kind (m :: * -> *)
without using ExplicitKindSignatures.
-}
newtype Wrap t m a = Wrap (Const (t m a) (m a))

wrap :: t m a -> Wrap t m a
wrap :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Wrap t m a
wrap = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Const (t m a) (m a) -> Wrap t m a
Wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). a -> Const a b
Const

unwrap :: Wrap t m a -> t m a
unwrap :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Wrap t m a -> t m a
unwrap (Wrap (Const t m a
m)) = t m a
m

lift :: (C t, Monad m) => m a -> Wrap t m a
lift :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(C t, Monad m) =>
m a -> Wrap t m a
lift = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Wrap t m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift


instance (C t, Monad m) => Functor (Wrap t m) where
   fmap :: forall a b. (a -> b) -> Wrap t m a -> Wrap t m b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance (C t, Monad m) => Applicative (Wrap t m) where
   pure :: forall a. a -> Wrap t m a
pure = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Wrap t m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(C t, Monad m) =>
a -> t m a
point
   <*> :: forall a b. Wrap t m (a -> b) -> Wrap t m a -> Wrap t m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (C t, Monad m) => Monad (Wrap t m) where
   return :: forall a. a -> Wrap t m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
   Wrap t m a
x >>= :: forall a b. Wrap t m a -> (a -> Wrap t m b) -> Wrap t m b
>>= a -> Wrap t m b
k  =  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Wrap t m a
wrap forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(C t, Monad m) =>
t m a -> (a -> t m b) -> t m b
bind (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Wrap t m a -> t m a
unwrap Wrap t m a
x) (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Wrap t m a -> t m a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Wrap t m b
k)