{-# LANGUAGE CPP, RankNTypes #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
module Control.Monad.Morph (
MFunctor(..),
generalize,
MMonad(..),
MonadTrans(lift),
squash,
(>|>),
(<|<),
(=<|),
(|>=)
) where
import Control.Monad.Trans.Class (MonadTrans(lift))
import qualified Control.Monad.Trans.Error as E
import qualified Control.Monad.Trans.Except as Ex
import qualified Control.Monad.Trans.Identity as I
import qualified Control.Monad.Trans.List as L
import qualified Control.Monad.Trans.Maybe as M
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.RWS.Lazy as RWS
import qualified Control.Monad.Trans.RWS.Strict as RWS'
import qualified Control.Monad.Trans.State.Lazy as S
import qualified Control.Monad.Trans.State.Strict as S'
import qualified Control.Monad.Trans.Writer.Lazy as W'
import qualified Control.Monad.Trans.Writer.Strict as W
import Data.Monoid (Monoid, mappend)
import Data.Functor.Compose (Compose (Compose))
import Data.Functor.Identity (runIdentity)
import Data.Functor.Product (Product (Pair))
import Control.Applicative.Backwards (Backwards (Backwards))
import Control.Applicative.Lift (Lift (Pure, Other))
import Control.Exception (try, IOException)
import Control.Monad ((=<<), (>=>), (<=<), join)
import Data.Functor.Identity (Identity)
class MFunctor t where
hoist :: (Monad m) => (forall a . m a -> n a) -> t m b -> t n b
instance MFunctor (E.ErrorT e) where
hoist :: (forall a. m a -> n a) -> ErrorT e m b -> ErrorT e n b
hoist nat :: forall a. m a -> n a
nat m :: ErrorT e m b
m = n (Either e b) -> ErrorT e n b
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
E.ErrorT (m (Either e b) -> n (Either e b)
forall a. m a -> n a
nat (ErrorT e m b -> m (Either e b)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
E.runErrorT ErrorT e m b
m))
instance MFunctor (Ex.ExceptT e) where
hoist :: (forall a. m a -> n a) -> ExceptT e m b -> ExceptT e n b
hoist nat :: forall a. m a -> n a
nat m :: ExceptT e m b
m = n (Either e b) -> ExceptT e n b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Ex.ExceptT (m (Either e b) -> n (Either e b)
forall a. m a -> n a
nat (ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Ex.runExceptT ExceptT e m b
m))
instance MFunctor I.IdentityT where
hoist :: (forall a. m a -> n a) -> IdentityT m b -> IdentityT n b
hoist nat :: forall a. m a -> n a
nat m :: IdentityT m b
m = n b -> IdentityT n b
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
I.IdentityT (m b -> n b
forall a. m a -> n a
nat (IdentityT m b -> m b
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
I.runIdentityT IdentityT m b
m))
instance MFunctor L.ListT where
hoist :: (forall a. m a -> n a) -> ListT m b -> ListT n b
hoist nat :: forall a. m a -> n a
nat m :: ListT m b
m = n [b] -> ListT n b
forall (m :: * -> *) a. m [a] -> ListT m a
L.ListT (m [b] -> n [b]
forall a. m a -> n a
nat (ListT m b -> m [b]
forall (m :: * -> *) a. ListT m a -> m [a]
L.runListT ListT m b
m))
instance MFunctor M.MaybeT where
hoist :: (forall a. m a -> n a) -> MaybeT m b -> MaybeT n b
hoist nat :: forall a. m a -> n a
nat m :: MaybeT m b
m = n (Maybe b) -> MaybeT n b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
M.MaybeT (m (Maybe b) -> n (Maybe b)
forall a. m a -> n a
nat (MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
M.runMaybeT MaybeT m b
m))
instance MFunctor (R.ReaderT r) where
hoist :: (forall a. m a -> n a) -> ReaderT r m b -> ReaderT r n b
hoist nat :: forall a. m a -> n a
nat m :: ReaderT r m b
m = (r -> n b) -> ReaderT r n b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT (\i :: r
i -> m b -> n b
forall a. m a -> n a
nat (ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT ReaderT r m b
m r
i))
instance MFunctor (RWS.RWST r w s) where
hoist :: (forall a. m a -> n a) -> RWST r w s m b -> RWST r w s n b
hoist nat :: forall a. m a -> n a
nat m :: RWST r w s m b
m = (r -> s -> n (b, s, w)) -> RWST r w s n b
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.RWST (\r :: r
r s :: s
s -> m (b, s, w) -> n (b, s, w)
forall a. m a -> n a
nat (RWST r w s m b -> r -> s -> m (b, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.runRWST RWST r w s m b
m r
r s
s))
instance MFunctor (RWS'.RWST r w s) where
hoist :: (forall a. m a -> n a) -> RWST r w s m b -> RWST r w s n b
hoist nat :: forall a. m a -> n a
nat m :: RWST r w s m b
m = (r -> s -> n (b, s, w)) -> RWST r w s n b
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS'.RWST (\r :: r
r s :: s
s -> m (b, s, w) -> n (b, s, w)
forall a. m a -> n a
nat (RWST r w s m b -> r -> s -> m (b, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS'.runRWST RWST r w s m b
m r
r s
s))
instance MFunctor (S.StateT s) where
hoist :: (forall a. m a -> n a) -> StateT s m b -> StateT s n b
hoist nat :: forall a. m a -> n a
nat m :: StateT s m b
m = (s -> n (b, s)) -> StateT s n b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S.StateT (\s :: s
s -> m (b, s) -> n (b, s)
forall a. m a -> n a
nat (StateT s m b -> s -> m (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT StateT s m b
m s
s))
instance MFunctor (S'.StateT s) where
hoist :: (forall a. m a -> n a) -> StateT s m b -> StateT s n b
hoist nat :: forall a. m a -> n a
nat m :: StateT s m b
m = (s -> n (b, s)) -> StateT s n b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S'.StateT (\s :: s
s -> m (b, s) -> n (b, s)
forall a. m a -> n a
nat (StateT s m b -> s -> m (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S'.runStateT StateT s m b
m s
s))
instance MFunctor (W.WriterT w) where
hoist :: (forall a. m a -> n a) -> WriterT w m b -> WriterT w n b
hoist nat :: forall a. m a -> n a
nat m :: WriterT w m b
m = n (b, w) -> WriterT w n b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W.WriterT (m (b, w) -> n (b, w)
forall a. m a -> n a
nat (WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W.runWriterT WriterT w m b
m))
instance MFunctor (W'.WriterT w) where
hoist :: (forall a. m a -> n a) -> WriterT w m b -> WriterT w n b
hoist nat :: forall a. m a -> n a
nat m :: WriterT w m b
m = n (b, w) -> WriterT w n b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W'.WriterT (m (b, w) -> n (b, w)
forall a. m a -> n a
nat (WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W'.runWriterT WriterT w m b
m))
instance Functor f => MFunctor (Compose f) where
hoist :: (forall a. m a -> n a) -> Compose f m b -> Compose f n b
hoist nat :: forall a. m a -> n a
nat (Compose f :: f (m b)
f) = f (n b) -> Compose f n b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((m b -> n b) -> f (m b) -> f (n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m b -> n b
forall a. m a -> n a
nat f (m b)
f)
instance MFunctor (Product f) where
hoist :: (forall a. m a -> n a) -> Product f m b -> Product f n b
hoist nat :: forall a. m a -> n a
nat (Pair f :: f b
f g :: m b
g) = f b -> n b -> Product f n b
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f b
f (m b -> n b
forall a. m a -> n a
nat m b
g)
instance MFunctor Backwards where
hoist :: (forall a. m a -> n a) -> Backwards m b -> Backwards n b
hoist nat :: forall a. m a -> n a
nat (Backwards f :: m b
f) = n b -> Backwards n b
forall k (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (m b -> n b
forall a. m a -> n a
nat m b
f)
instance MFunctor Lift where
hoist :: (forall a. m a -> n a) -> Lift m b -> Lift n b
hoist _ (Pure a :: b
a) = b -> Lift n b
forall (f :: * -> *) a. a -> Lift f a
Pure b
a
hoist nat :: forall a. m a -> n a
nat (Other f :: m b
f) = n b -> Lift n b
forall (f :: * -> *) a. f a -> Lift f a
Other (m b -> n b
forall a. m a -> n a
nat m b
f)
generalize :: Monad m => Identity a -> m a
generalize :: Identity a -> m a
generalize = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Identity a -> a) -> Identity a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity
{-# INLINABLE generalize #-}
class (MFunctor t, MonadTrans t) => MMonad t where
embed :: (Monad n) => (forall a . m a -> t n a) -> t m b -> t n b
squash :: (Monad m, MMonad t) => t (t m) a -> t m a
squash :: t (t m) a -> t m a
squash = (forall a. t m a -> t m a) -> t (t m) a -> t m a
forall (t :: (* -> *) -> * -> *) (n :: * -> *) (m :: * -> *) b.
(MMonad t, Monad n) =>
(forall a. m a -> t n a) -> t m b -> t n b
embed forall a. a -> a
forall a. t m a -> t m a
id
{-# INLINABLE squash #-}
infixr 2 >|>, =<|
infixl 2 <|<, |>=
(>|>)
:: (Monad m3, MMonad t)
=> (forall a . m1 a -> t m2 a)
-> (forall b . m2 b -> t m3 b)
-> m1 c -> t m3 c
(f :: forall a. m1 a -> t m2 a
f >|> :: (forall a. m1 a -> t m2 a)
-> (forall b. m2 b -> t m3 b) -> m1 c -> t m3 c
>|> g :: forall b. m2 b -> t m3 b
g) m :: m1 c
m = (forall b. m2 b -> t m3 b) -> t m2 c -> t m3 c
forall (t :: (* -> *) -> * -> *) (n :: * -> *) (m :: * -> *) b.
(MMonad t, Monad n) =>
(forall a. m a -> t n a) -> t m b -> t n b
embed forall b. m2 b -> t m3 b
g (m1 c -> t m2 c
forall a. m1 a -> t m2 a
f m1 c
m)
{-# INLINABLE (>|>) #-}
(<|<)
:: (Monad m3, MMonad t)
=> (forall b . m2 b -> t m3 b)
-> (forall a . m1 a -> t m2 a)
-> m1 c -> t m3 c
(g :: forall b. m2 b -> t m3 b
g <|< :: (forall b. m2 b -> t m3 b)
-> (forall a. m1 a -> t m2 a) -> m1 c -> t m3 c
<|< f :: forall a. m1 a -> t m2 a
f) m :: m1 c
m = (forall b. m2 b -> t m3 b) -> t m2 c -> t m3 c
forall (t :: (* -> *) -> * -> *) (n :: * -> *) (m :: * -> *) b.
(MMonad t, Monad n) =>
(forall a. m a -> t n a) -> t m b -> t n b
embed forall b. m2 b -> t m3 b
g (m1 c -> t m2 c
forall a. m1 a -> t m2 a
f m1 c
m)
{-# INLINABLE (<|<) #-}
(=<|) :: (Monad n, MMonad t) => (forall a . m a -> t n a) -> t m b -> t n b
=<| :: (forall a. m a -> t n a) -> t m b -> t n b
(=<|) = (forall a. m a -> t n a) -> t m b -> t n b
forall (t :: (* -> *) -> * -> *) (n :: * -> *) (m :: * -> *) b.
(MMonad t, Monad n) =>
(forall a. m a -> t n a) -> t m b -> t n b
embed
{-# INLINABLE (=<|) #-}
(|>=) :: (Monad n, MMonad t) => t m b -> (forall a . m a -> t n a) -> t n b
t :: t m b
t |>= :: t m b -> (forall a. m a -> t n a) -> t n b
|>= f :: forall a. m a -> t n a
f = (forall a. m a -> t n a) -> t m b -> t n b
forall (t :: (* -> *) -> * -> *) (n :: * -> *) (m :: * -> *) b.
(MMonad t, Monad n) =>
(forall a. m a -> t n a) -> t m b -> t n b
embed forall a. m a -> t n a
f t m b
t
{-# INLINABLE (|>=) #-}
instance (E.Error e) => MMonad (E.ErrorT e) where
embed :: (forall a. m a -> ErrorT e n a) -> ErrorT e m b -> ErrorT e n b
embed f :: forall a. m a -> ErrorT e n a
f m :: ErrorT e m b
m = n (Either e b) -> ErrorT e n b
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
E.ErrorT (do
Either e (Either e b)
x <- ErrorT e n (Either e b) -> n (Either e (Either e b))
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
E.runErrorT (m (Either e b) -> ErrorT e n (Either e b)
forall a. m a -> ErrorT e n a
f (ErrorT e m b -> m (Either e b)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
E.runErrorT ErrorT e m b
m))
Either e b -> n (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (case Either e (Either e b)
x of
Left e :: e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right (Left e :: e
e) -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right (Right a :: b
a) -> b -> Either e b
forall a b. b -> Either a b
Right b
a ) )
instance MMonad (Ex.ExceptT e) where
embed :: (forall a. m a -> ExceptT e n a) -> ExceptT e m b -> ExceptT e n b
embed f :: forall a. m a -> ExceptT e n a
f m :: ExceptT e m b
m = n (Either e b) -> ExceptT e n b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Ex.ExceptT (do
Either e (Either e b)
x <- ExceptT e n (Either e b) -> n (Either e (Either e b))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Ex.runExceptT (m (Either e b) -> ExceptT e n (Either e b)
forall a. m a -> ExceptT e n a
f (ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Ex.runExceptT ExceptT e m b
m))
Either e b -> n (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (case Either e (Either e b)
x of
Left e :: e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right (Left e :: e
e) -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right (Right a :: b
a) -> b -> Either e b
forall a b. b -> Either a b
Right b
a ) )
instance MMonad I.IdentityT where
embed :: (forall a. m a -> IdentityT n a) -> IdentityT m b -> IdentityT n b
embed f :: forall a. m a -> IdentityT n a
f m :: IdentityT m b
m = m b -> IdentityT n b
forall a. m a -> IdentityT n a
f (IdentityT m b -> m b
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
I.runIdentityT IdentityT m b
m)
instance MMonad L.ListT where
embed :: (forall a. m a -> ListT n a) -> ListT m b -> ListT n b
embed f :: forall a. m a -> ListT n a
f m :: ListT m b
m = n [b] -> ListT n b
forall (m :: * -> *) a. m [a] -> ListT m a
L.ListT (do
[[b]]
x <- ListT n [b] -> n [[b]]
forall (m :: * -> *) a. ListT m a -> m [a]
L.runListT (m [b] -> ListT n [b]
forall a. m a -> ListT n a
f (ListT m b -> m [b]
forall (m :: * -> *) a. ListT m a -> m [a]
L.runListT ListT m b
m))
[b] -> n [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[b]]
x))
instance MMonad M.MaybeT where
embed :: (forall a. m a -> MaybeT n a) -> MaybeT m b -> MaybeT n b
embed f :: forall a. m a -> MaybeT n a
f m :: MaybeT m b
m = n (Maybe b) -> MaybeT n b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
M.MaybeT (do
Maybe (Maybe b)
x <- MaybeT n (Maybe b) -> n (Maybe (Maybe b))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
M.runMaybeT (m (Maybe b) -> MaybeT n (Maybe b)
forall a. m a -> MaybeT n a
f (MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
M.runMaybeT MaybeT m b
m))
Maybe b -> n (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe (Maybe b)
x of
Nothing -> Maybe b
forall a. Maybe a
Nothing
Just Nothing -> Maybe b
forall a. Maybe a
Nothing
Just (Just a :: b
a) -> b -> Maybe b
forall a. a -> Maybe a
Just b
a ) )
instance MMonad (R.ReaderT r) where
embed :: (forall a. m a -> ReaderT r n a) -> ReaderT r m b -> ReaderT r n b
embed f :: forall a. m a -> ReaderT r n a
f m :: ReaderT r m b
m = (r -> n b) -> ReaderT r n b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT (\i :: r
i -> ReaderT r n b -> r -> n b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (m b -> ReaderT r n b
forall a. m a -> ReaderT r n a
f (ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT ReaderT r m b
m r
i)) r
i)
instance (Monoid w) => MMonad (W.WriterT w) where
embed :: (forall a. m a -> WriterT w n a) -> WriterT w m b -> WriterT w n b
embed f :: forall a. m a -> WriterT w n a
f m :: WriterT w m b
m = n (b, w) -> WriterT w n b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W.WriterT (do
~((a :: b
a, w1 :: w
w1), w2 :: w
w2) <- WriterT w n (b, w) -> n ((b, w), w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W.runWriterT (m (b, w) -> WriterT w n (b, w)
forall a. m a -> WriterT w n a
f (WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W.runWriterT WriterT w m b
m))
(b, w) -> n (b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2) )
instance (Monoid w) => MMonad (W'.WriterT w) where
embed :: (forall a. m a -> WriterT w n a) -> WriterT w m b -> WriterT w n b
embed f :: forall a. m a -> WriterT w n a
f m :: WriterT w m b
m = n (b, w) -> WriterT w n b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W'.WriterT (do
((a :: b
a, w1 :: w
w1), w2 :: w
w2) <- WriterT w n (b, w) -> n ((b, w), w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W'.runWriterT (m (b, w) -> WriterT w n (b, w)
forall a. m a -> WriterT w n a
f (WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W'.runWriterT WriterT w m b
m))
(b, w) -> n (b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w1 w
w2) )