{-# OPTIONS -fno-warn-orphans #-}

module Control.Monad.Ology.Specific.StateT
    ( module Control.Monad.Trans.State
    , module Control.Monad.Ology.Specific.StateT
    ) where

import Control.Monad.Ology.General
import Control.Monad.Trans.State hiding (liftCallCC, liftCatch, liftListen, liftPass)
import Import

instance TransConstraint Functor (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
Functor m =>
Dict (Functor (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance TransConstraint Monad (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type). Monad m => Dict (Monad (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance TransConstraint MonadIO (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadIO m =>
Dict (MonadIO (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance TransConstraint MonadFail (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadFail m =>
Dict (MonadFail (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance TransConstraint MonadFix (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadFix m =>
Dict (MonadFix (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance TransConstraint MonadPlus (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadPlus m =>
Dict (MonadPlus (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance MonadTransCoerce (StateT a) where
    transCoerce :: forall (m1 :: Type -> Type) (m2 :: Type -> Type).
Coercible m1 m2 =>
Dict (Coercible (StateT a m1) (StateT a m2))
transCoerce = forall (a :: Constraint). a => Dict a
Dict

instance MonadException m => MonadException (StateT s m) where
    type Exc (StateT s m) = Exc m
    throwExc :: forall a. Exc (StateT s m) -> StateT s m a
throwExc Exc (StateT s m)
e = forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadException m => Exc m -> m a
throwExc Exc (StateT s m)
e
    catchExc :: forall a.
StateT s m a -> (Exc (StateT s m) -> StateT s m a) -> StateT s m a
catchExc StateT s m a
tma Exc (StateT s m) -> StateT s m a
handler = forall (t :: TransKind) (m :: Type -> Type) r.
(MonadTransTunnel t, Monad m) =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t r))
-> t m r
tunnel forall a b. (a -> b) -> a -> b
$ \forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift -> forall (m :: Type -> Type) a.
MonadException m =>
m a -> (Exc m -> m a) -> m a
catchExc (forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift StateT s m a
tma) forall a b. (a -> b) -> a -> b
$ \Exc m
e -> forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift forall a b. (a -> b) -> a -> b
$ Exc (StateT s m) -> StateT s m a
handler Exc m
e

instance TransConstraint MonadException (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadException m =>
Dict (MonadException (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance MonadThrow e m => MonadThrow e (StateT s m) where
    throw :: forall a. e -> StateT s m a
throw e
e = forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: Type -> Type) a. MonadThrow e m => e -> m a
throw e
e

instance TransConstraint (MonadThrow e) (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadThrow e m =>
Dict (MonadThrow e (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance MonadCatch e m => MonadCatch e (StateT s m) where
    catch :: forall a. StateT s m a -> (e -> StateT s m a) -> StateT s m a
catch StateT s m a
ma e -> StateT s m a
handler = forall (t :: TransKind) (m :: Type -> Type) r.
(MonadTransTunnel t, Monad m) =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t r))
-> t m r
tunnel forall a b. (a -> b) -> a -> b
$ \forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift -> forall e (m :: Type -> Type) a.
MonadCatch e m =>
m a -> (e -> m a) -> m a
catch (forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift StateT s m a
ma) forall a b. (a -> b) -> a -> b
$ \e
e -> forall (m1 :: Type -> Type) a.
Monad m1 =>
StateT s m1 a -> m1 (Tunnel (StateT s) a)
unlift forall a b. (a -> b) -> a -> b
$ e -> StateT s m a
handler e
e

instance TransConstraint (MonadCatch e) (StateT s) where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadCatch e m =>
Dict (MonadCatch e (StateT s m))
hasTransConstraint = forall (a :: Constraint). a => Dict a
Dict

instance MonadTransHoist (StateT s) where
    hoist :: forall (m1 :: Type -> Type) (m2 :: Type -> Type).
(Monad m1, Monad m2) =>
(m1 --> m2) -> StateT s m1 --> StateT s m2
hoist = forall (t :: TransKind) (m1 :: Type -> Type) (m2 :: Type -> Type).
(MonadTransTunnel t, Monad m1, Monad m2) =>
(m1 --> m2) -> t m1 --> t m2
tunnelHoist

instance MonadTransTunnel (StateT s) where
    type Tunnel (StateT s) = (,) (Endo s)
    tunnel :: forall (m :: Type -> Type) r.
Monad m =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  StateT s m1 a -> m1 (Tunnel (StateT s) a))
 -> m (Tunnel (StateT s) r))
-> StateT s m r
tunnel (forall (m1 :: Type -> Type) a.
 Monad m1 =>
 StateT s m1 a -> m1 (Tunnel (StateT s) a))
-> m (Tunnel (StateT s) r)
call =
        forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
olds ->
            forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Endo s -> s
sf, r
r) -> (r
r, s -> s
sf s
olds)) forall a b. (a -> b) -> a -> b
$
            (forall (m1 :: Type -> Type) a.
 Monad m1 =>
 StateT s m1 a -> m1 (Tunnel (StateT s) a))
-> m (Tunnel (StateT s) r)
call forall a b. (a -> b) -> a -> b
$ \(StateT s -> m1 (a, s)
smrs) -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
a, s
s) -> (forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. Applicative f => a -> f a
pure s
s, a
a)) forall a b. (a -> b) -> a -> b
$ s -> m1 (a, s)
smrs s
olds

instance MonadTransUnlift (StateT s) where
    liftWithUnlift :: forall (m :: Type -> Type) r.
MonadIO m =>
(Unlift MonadTunnelIO (StateT s) -> m r) -> StateT s m r
liftWithUnlift Unlift MonadTunnelIO (StateT s) -> m r
call = forall (m :: Type -> Type) s a.
MonadIO m =>
(MVar s -> m a) -> StateT s m a
liftWithMVarStateT forall a b. (a -> b) -> a -> b
$ \MVar s
var -> Unlift MonadTunnelIO (StateT s) -> m r
call forall a b. (a -> b) -> a -> b
$ forall s. MVar s -> Unlift MonadTunnelIO (StateT s)
mVarRunStateT MVar s
var

-- | Run the 'StateT' on an 'MVar', taking the initial state and putting the final state.
mVarRunStateT :: MVar s -> Unlift MonadTunnelIO (StateT s)
mVarRunStateT :: forall s. MVar s -> Unlift MonadTunnelIO (StateT s)
mVarRunStateT MVar s
var (StateT s -> m (a, s)
smr) =
    forall (m :: Type -> Type) r.
MonadTunnelIO m =>
((forall a. m a -> IO (TunnelIO m a)) -> IO (TunnelIO m r)) -> m r
tunnelIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO (TunnelIO m a)
unlift ->
        forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar s
var forall a b. (a -> b) -> a -> b
$ \s
olds ->
            forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TunnelIO m (a, s)
fas -> (forall a. a -> Maybe a -> a
fromMaybe s
olds forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadInner m => m a -> Maybe a
mToMaybe forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd TunnelIO m (a, s)
fas, forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst TunnelIO m (a, s)
fas)) forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO (TunnelIO m a)
unlift forall a b. (a -> b) -> a -> b
$ s -> m (a, s)
smr s
olds

-- | Take the 'MVar' before and put it back after.
mVarRunLocked :: MonadTunnelIO m => MVar s -> m --> m
mVarRunLocked :: forall (m :: Type -> Type) s. MonadTunnelIO m => MVar s -> m --> m
mVarRunLocked MVar s
var m a
ma = forall s. MVar s -> Unlift MonadTunnelIO (StateT s)
mVarRunStateT MVar s
var forall a b. (a -> b) -> a -> b
$ forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
ma

discardingStateTUnlift :: s -> Unlift MonadIO (StateT s)
discardingStateTUnlift :: forall s. s -> Unlift MonadIO (StateT s)
discardingStateTUnlift s
s StateT s m a
mr = do
    (a
r, s
_discarded) <- forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT StateT s m a
mr s
s
    forall (m :: Type -> Type) a. Monad m => a -> m a
return a
r

-- | Dangerous, because the MVar won't be released on exception.
dangerousMVarRunStateT :: MVar s -> Unlift MonadIO (StateT s)
dangerousMVarRunStateT :: forall s. MVar s -> Unlift MonadIO (StateT s)
dangerousMVarRunStateT MVar s
var (StateT s -> m (a, s)
smr) = do
    s
olds <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar s
var
    (a
a, s
news) <- s -> m (a, s)
smr s
olds
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar s
var s
news
    forall (m :: Type -> Type) a. Monad m => a -> m a
return a
a

liftStateT :: (Traversable f, Applicative m) => StateT s m a -> StateT (f s) m (f a)
liftStateT :: forall (f :: Type -> Type) (m :: Type -> Type) s a.
(Traversable f, Applicative m) =>
StateT s m a -> StateT (f s) m (f a)
liftStateT (StateT s -> m (a, s)
smas) = forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \f s
fs -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\f (a, s)
fas -> (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst f (a, s)
fas, forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd f (a, s)
fas)) forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse s -> m (a, s)
smas f s
fs

liftWithMVarStateT :: MonadIO m => (MVar s -> m a) -> StateT s m a
liftWithMVarStateT :: forall (m :: Type -> Type) s a.
MonadIO m =>
(MVar s -> m a) -> StateT s m a
liftWithMVarStateT MVar s -> m a
vma =
    forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
initialstate -> do
        MVar s
var <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar s
initialstate
        a
r <- MVar s -> m a
vma MVar s
var
        s
finalstate <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar s
var
        forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
r, s
finalstate)