{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Hedgehog.Internal.Distributive (
    MonadTransDistributive(..)
  ) where

import           Control.Monad (join)
import           Control.Monad.Morph (MFunctor(..))
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.Identity (IdentityT(..))
import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import           Control.Monad.Trans.Maybe (MaybeT(..))
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import           Control.Monad.Trans.Reader (ReaderT(..))
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict

import           Data.Kind (Type)
import           GHC.Exts (Constraint)

------------------------------------------------------------------------
-- * MonadTransDistributive

class MonadTransDistributive g where
  type Transformer
    (f :: (Type -> Type) -> Type -> Type)
    (g :: (Type -> Type) -> Type -> Type)
    (m :: Type -> Type) :: Constraint

  type Transformer f g m = (
      Monad m
    , Monad (f m)
    , Monad (g m)
    , Monad (f (g m))
    , MonadTrans f
    , MFunctor f
    )

  -- | Distribute one monad transformer over another.
  --
  distributeT :: Transformer f g m => g (f m) a -> f (g m) a

instance MonadTransDistributive IdentityT where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f IdentityT m =>
IdentityT (f m) a -> f (IdentityT m) a
distributeT IdentityT (f m) a
m =
    IdentityT m a -> f (IdentityT m) a
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IdentityT m a -> f (IdentityT m) a)
-> (a -> IdentityT m a) -> a -> f (IdentityT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IdentityT m a
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (m a -> IdentityT m a) -> (a -> m a) -> a -> IdentityT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f (IdentityT m) a) -> f (IdentityT m) a -> f (IdentityT m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> IdentityT m a) -> f m a -> f (IdentityT m) a
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> IdentityT m a
forall a. m a -> IdentityT m a
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IdentityT (f m) a -> f m a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT (f m) a
m)

instance MonadTransDistributive MaybeT where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f MaybeT m =>
MaybeT (f m) a -> f (MaybeT m) a
distributeT MaybeT (f m) a
m =
    MaybeT m a -> f (MaybeT m) a
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT m a -> f (MaybeT m) a)
-> (Maybe a -> MaybeT m a) -> Maybe a -> f (MaybeT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (Maybe a -> m (Maybe a)) -> Maybe a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> f (MaybeT m) a)
-> f (MaybeT m) (Maybe a) -> f (MaybeT m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> MaybeT m a)
-> f m (Maybe a) -> f (MaybeT m) (Maybe a)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> MaybeT m a
forall a. m a -> MaybeT m a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT (f m) a -> f m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (f m) a
m)

instance MonadTransDistributive (ExceptT x) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (ExceptT x) m =>
ExceptT x (f m) a -> f (ExceptT x m) a
distributeT ExceptT x (f m) a
m =
    ExceptT x m a -> f (ExceptT x m) a
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT x m a -> f (ExceptT x m) a)
-> (Either x a -> ExceptT x m a) -> Either x a -> f (ExceptT x m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either x a) -> ExceptT x m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either x a) -> ExceptT x m a)
-> (Either x a -> m (Either x a)) -> Either x a -> ExceptT x m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either x a -> m (Either x a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either x a -> f (ExceptT x m) a)
-> f (ExceptT x m) (Either x a) -> f (ExceptT x m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> ExceptT x m a)
-> f m (Either x a) -> f (ExceptT x m) (Either x a)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> ExceptT x m a
forall a. m a -> ExceptT x m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT x m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT x (f m) a -> f m (Either x a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT x (f m) a
m)

instance MonadTransDistributive (ReaderT r) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (ReaderT r) m =>
ReaderT r (f m) a -> f (ReaderT r m) a
distributeT ReaderT r (f m) a
m =
    f (ReaderT r m) (f (ReaderT r m) a) -> f (ReaderT r m) a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (f (ReaderT r m) (f (ReaderT r m) a) -> f (ReaderT r m) a)
-> ((r -> m (f (ReaderT r m) a))
    -> f (ReaderT r m) (f (ReaderT r m) a))
-> (r -> m (f (ReaderT r m) a))
-> f (ReaderT r m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT r m (f (ReaderT r m) a)
-> f (ReaderT r m) (f (ReaderT r m) a)
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT r m (f (ReaderT r m) a)
 -> f (ReaderT r m) (f (ReaderT r m) a))
-> ((r -> m (f (ReaderT r m) a))
    -> ReaderT r m (f (ReaderT r m) a))
-> (r -> m (f (ReaderT r m) a))
-> f (ReaderT r m) (f (ReaderT r m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> m (f (ReaderT r m) a)) -> ReaderT r m (f (ReaderT r m) a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (f (ReaderT r m) a)) -> f (ReaderT r m) a)
-> (r -> m (f (ReaderT r m) a)) -> f (ReaderT r m) a
forall a b. (a -> b) -> a -> b
$ \r
r ->
      f (ReaderT r m) a -> m (f (ReaderT r m) a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (ReaderT r m) a -> m (f (ReaderT r m) a))
-> (f m a -> f (ReaderT r m) a) -> f m a -> m (f (ReaderT r m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. m a -> ReaderT r m a) -> f m a -> f (ReaderT r m) a
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> ReaderT r m a
forall a. m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f m a -> m (f (ReaderT r m) a)) -> f m a -> m (f (ReaderT r m) a)
forall a b. (a -> b) -> a -> b
$ ReaderT r (f m) a -> r -> f m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r (f m) a
m r
r

instance Monoid w => MonadTransDistributive (Lazy.WriterT w) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (WriterT w) m =>
WriterT w (f m) a -> f (WriterT w m) a
distributeT WriterT w (f m) a
m =
    WriterT w m a -> f (WriterT w m) a
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT w m a -> f (WriterT w m) a)
-> ((a, w) -> WriterT w m a) -> (a, w) -> f (WriterT w m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT (m (a, w) -> WriterT w m a)
-> ((a, w) -> m (a, w)) -> (a, w) -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m (a, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, w) -> f (WriterT w m) a)
-> f (WriterT w m) (a, w) -> f (WriterT w m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> WriterT w m a)
-> f m (a, w) -> f (WriterT w m) (a, w)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> WriterT w m a
forall a. m a -> WriterT w m a
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT w (f m) a -> f m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w (f m) a
m)

instance Monoid w => MonadTransDistributive (Strict.WriterT w) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (WriterT w) m =>
WriterT w (f m) a -> f (WriterT w m) a
distributeT WriterT w (f m) a
m = do
    WriterT w m a -> f (WriterT w m) a
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT w m a -> f (WriterT w m) a)
-> ((a, w) -> WriterT w m a) -> (a, w) -> f (WriterT w m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT (m (a, w) -> WriterT w m a)
-> ((a, w) -> m (a, w)) -> (a, w) -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m (a, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, w) -> f (WriterT w m) a)
-> f (WriterT w m) (a, w) -> f (WriterT w m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> WriterT w m a)
-> f m (a, w) -> f (WriterT w m) (a, w)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> f m b -> f n b
hoist m a -> WriterT w m a
forall a. m a -> WriterT w m a
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT w (f m) a -> f m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w (f m) a
m)

instance MonadTransDistributive (Lazy.StateT s) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (StateT s) m =>
StateT s (f m) a -> f (StateT s m) a
distributeT StateT s (f m) a
m = do
    s       <- StateT s m s -> f (StateT s m) s
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
Lazy.get
    (a, s') <- hoist lift (Lazy.runStateT m s)
    lift (Lazy.put s')
    return a

instance MonadTransDistributive (Strict.StateT s) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (StateT s) m =>
StateT s (f m) a -> f (StateT s m) a
distributeT StateT s (f m) a
m = do
    s       <- StateT s m s -> f (StateT s m) s
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
Strict.get
    (a, s') <- hoist lift (Strict.runStateT m s)
    lift (Strict.put s')
    return a

instance Monoid w => MonadTransDistributive (Lazy.RWST r w s) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (RWST r w s) m =>
RWST r w s (f m) a -> f (RWST r w s m) a
distributeT RWST r w s (f m) a
m = do
    -- ask and get combined
    (r, s0)    <- RWST r w s m (r, s) -> f (RWST r w s m) (r, s)
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RWST r w s m (r, s) -> f (RWST r w s m) (r, s))
-> ((r -> s -> m ((r, s), s, w)) -> RWST r w s m (r, s))
-> (r -> s -> m ((r, s), s, w))
-> f (RWST r w s m) (r, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> s -> m ((r, s), s, w)) -> RWST r w s m (r, s)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST ((r -> s -> m ((r, s), s, w)) -> f (RWST r w s m) (r, s))
-> (r -> s -> m ((r, s), s, w)) -> f (RWST r w s m) (r, s)
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> ((r, s), s, w) -> m ((r, s), s, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((r
r, s
s), s
s, w
forall a. Monoid a => a
mempty)
    (a, s1, w) <- hoist lift (Lazy.runRWST m r s0)
    -- tell and put combined
    lift $ Lazy.RWST $ \r
_ s
_ -> (a, s, w) -> m (a, s, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, s
s1, w
w)

instance Monoid w => MonadTransDistributive (Strict.RWST r w s) where
  distributeT :: forall (f :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer f (RWST r w s) m =>
RWST r w s (f m) a -> f (RWST r w s m) a
distributeT RWST r w s (f m) a
m = do
    -- ask and get combined
    (r, s0)    <- RWST r w s m (r, s) -> f (RWST r w s m) (r, s)
forall (m :: * -> *) a. Monad m => m a -> f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RWST r w s m (r, s) -> f (RWST r w s m) (r, s))
-> ((r -> s -> m ((r, s), s, w)) -> RWST r w s m (r, s))
-> (r -> s -> m ((r, s), s, w))
-> f (RWST r w s m) (r, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> s -> m ((r, s), s, w)) -> RWST r w s m (r, s)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST ((r -> s -> m ((r, s), s, w)) -> f (RWST r w s m) (r, s))
-> (r -> s -> m ((r, s), s, w)) -> f (RWST r w s m) (r, s)
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> ((r, s), s, w) -> m ((r, s), s, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((r
r, s
s), s
s, w
forall a. Monoid a => a
mempty)
    (a, s1, w) <- hoist lift (Strict.runRWST m r s0)
    -- tell and put combined
    lift $ Strict.RWST $ \r
_ s
_ -> (a, s, w) -> m (a, s, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, s
s1, w
w)