{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,
             ScopedTypeVariables #-}

---------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.MState
-- Copyright   :  (c) Nils Schweinsberg 2010
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  mail@n-sch.de
-- Stability   :  unstable
-- Portability :  portable
--
-- MState: A consistent state monad for concurrent applications.
--
---------------------------------------------------------------------------

module Control.Concurrent.MState
    (
      -- * The MState Monad
      MState
    , module Control.Monad.State.Class
    , runMState
    , evalMState
    , execMState
    , mapMState
    , mapMState_
    -- , withMState
    , modifyM
    , modifyM_

      -- * Concurrency
    , forkM
    , forkM_
    , killMState
    , waitM

      -- * Example
      -- $example
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.State.Class
import Control.Monad.Cont
import Control.Monad.Except
import qualified Control.Monad.Fail as Fail
import Control.Monad.Reader
import Control.Monad.Writer

import Control.Concurrent
import Control.Concurrent.STM

import Control.Monad.IO.Peel
import Control.Exception.Peel
import Control.Monad.Trans.Peel


-- | The MState monad is a state monad for concurrent applications. To create a
-- new thread sharing the same (modifiable) state use the `forkM` function.
newtype MState t m a = MState { forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' :: (TVar t, TVar [(ThreadId, TMVar ())]) -> m a }

-- | Wait for all `TMVars` to get filled by their processes.
waitForTermination :: MonadIO m
                   => TVar [(ThreadId, TMVar ())]
                   -> m ()
waitForTermination :: forall (m :: * -> *).
MonadIO m =>
TVar [(ThreadId, TMVar ())] -> m ()
waitForTermination = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TMVar a -> STM a
takeTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. TVar a -> STM a
readTVar)

-- | Run a `MState` application, returning both, the function value and the
-- final state. Note that this function has to wait for all threads to finish
-- before it can return the final state.
runMState :: MonadPeelIO m
          => MState t m a      -- ^ Action to run
          -> t                 -- ^ Initial state value
          -> m (a,t)
runMState :: forall (m :: * -> *) t a.
MonadPeelIO m =>
MState t m a -> t -> m (a, t)
runMState MState t m a
m t
t = do
  (a
a, Maybe t
t') <- forall (m :: * -> *) t a.
MonadPeelIO m =>
Bool -> MState t m a -> t -> m (a, Maybe t)
runAndWaitMaybe Bool
True MState t m a
m t
t
  case Maybe t
t' of
      Just t
t'' -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, t
t'')
      Maybe t
_ -> forall a. HasCallStack => a
undefined  -- impossible

runAndWaitMaybe :: MonadPeelIO m
                => Bool
                -> MState t m a
                -> t
                -> m (a, Maybe t)
runAndWaitMaybe :: forall (m :: * -> *) t a.
MonadPeelIO m =>
Bool -> MState t m a -> t -> m (a, Maybe t)
runAndWaitMaybe Bool
b MState t m a
m t
t = do

    ThreadId
myI <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
    TMVar ()
myM <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (TMVar a)
newEmptyTMVarIO
    TVar t
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO t
t
    TVar [(ThreadId, TMVar ())]
c   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO [(ThreadId
myI, TMVar ()
myM)]
    a
a   <- forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t
ref, TVar [(ThreadId, TMVar ())]
c) forall (m :: * -> *) a b. MonadPeelIO m => m a -> m b -> m a
`finally` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
myM ())
    if Bool
b then do
      -- wait before getting the final state
      forall (m :: * -> *).
MonadIO m =>
TVar [(ThreadId, TMVar ())] -> m ()
waitForTermination TVar [(ThreadId, TMVar ())]
c
      t
t'  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar t
ref
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall a. a -> Maybe a
Just t
t')
     else
      -- don't wait for other threads
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall a. Maybe a
Nothing)

-- | Run a `MState` application, ignoring the final state. If the first
-- argument is `True` this function will wait for all threads to finish before
-- returning the final result, otherwise it will return the function value as
-- soon as its acquired.
evalMState :: MonadPeelIO m
           => Bool              -- ^ Wait for all threads to finish?
           -> MState t m a      -- ^ Action to evaluate
           -> t                 -- ^ Initial state value
           -> m a
evalMState :: forall (m :: * -> *) t a.
MonadPeelIO m =>
Bool -> MState t m a -> t -> m a
evalMState Bool
b MState t m a
m t
t = forall (m :: * -> *) t a.
MonadPeelIO m =>
Bool -> MState t m a -> t -> m (a, Maybe t)
runAndWaitMaybe Bool
b MState t m a
m t
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- | Run a `MState` application, ignoring the function value. This function
-- will wait for all threads to finish before returning the final state.
execMState :: MonadPeelIO m
           => MState t m a      -- ^ Action to execute
           -> t                 -- ^ Initial state value
           -> m t
execMState :: forall (m :: * -> *) t a. MonadPeelIO m => MState t m a -> t -> m t
execMState MState t m a
m t
t = forall (m :: * -> *) t a.
MonadPeelIO m =>
MState t m a -> t -> m (a, t)
runMState MState t m a
m t
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

-- | Map a stateful computation from one @(return value, state)@ pair to
-- another. See "Control.Monad.State.Lazy" for more information. Be aware that
-- both MStates still share the same state.
mapMState :: (MonadIO m, MonadIO n)
          => (m (a,t) -> n (b,t))
          -> MState t m a
          -> MState t n b
mapMState :: forall (m :: * -> *) (n :: * -> *) a t b.
(MonadIO m, MonadIO n) =>
(m (a, t) -> n (b, t)) -> MState t m a -> MState t n b
mapMState m (a, t) -> n (b, t)
f MState t m a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \s :: (TVar t, TVar [(ThreadId, TMVar ())])
s@(TVar t
r,TVar [(ThreadId, TMVar ())]
_) -> do
    ~(b
b,t
v') <- m (a, t) -> n (b, t)
f forall a b. (a -> b) -> a -> b
$ do
        a
a <- forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
s
        t
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar t
r
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,t
v)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar t
r t
v'
    forall (m :: * -> *) a. Monad m => a -> m a
return b
b

mapMState_ :: (MonadIO n)
           => (m a -> n b)
           -> MState t m a
           -> MState t n b
mapMState_ :: forall (n :: * -> *) (m :: * -> *) a b t.
MonadIO n =>
(m a -> n b) -> MState t m a -> MState t n b
mapMState_ m a -> n b
f MState t m a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> do
    b
b <- m a -> n b
f forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
s
    forall (m :: * -> *) a. Monad m => a -> m a
return b
b

{- TODO: What's the point of this function? Does it make sense for MStates?

-- | Apply a function to the state before running the `MState`
withMState :: (MonadIO m)
           => (t -> t)
           -> MState t m a
           -> MState t m a
withMState f m = MState $ \s@(r,_) -> do
    liftIO . atomically $ do
        v <- readTVar r
        writeTVar r (f v)
    runMState' m s

-}

-- | Modify the `MState`, block all other threads from accessing the state in
-- the meantime (using `atomically` from the "Control.Concurrent.STM" library).
modifyM :: MonadIO m => (t -> (a,t)) -> MState t m a
modifyM :: forall (m :: * -> *) t a.
MonadIO m =>
(t -> (a, t)) -> MState t m a
modifyM t -> (a, t)
f = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t
t,TVar [(ThreadId, TMVar ())]
_) ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        t
v <- forall a. TVar a -> STM a
readTVar TVar t
t
        let (a
a,t
v') = t -> (a, t)
f t
v
        forall a. TVar a -> a -> STM ()
writeTVar TVar t
t t
v'
        forall (m :: * -> *) a. Monad m => a -> m a
return a
a

modifyM_ :: MonadIO m => (t -> t) -> MState t m ()
modifyM_ :: forall (m :: * -> *) t. MonadIO m => (t -> t) -> MState t m ()
modifyM_ t -> t
f = forall (m :: * -> *) t a.
MonadIO m =>
(t -> (a, t)) -> MState t m a
modifyM (\t
t -> ((), t -> t
f t
t))

fork :: MonadPeelIO m => m () -> m ThreadId
fork :: forall (m :: * -> *). MonadPeelIO m => m () -> m ThreadId
fork m ()
m = do
  m () -> IO (m ())
k <- forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ m () -> IO (m ())
k m ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Start a new stateful thread.
forkM :: MonadPeelIO m
      => MState t m ()
      -> MState t m ThreadId
forkM :: forall (m :: * -> *) t.
MonadPeelIO m =>
MState t m () -> MState t m ThreadId
forkM MState t m ()
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \s :: (TVar t, TVar [(ThreadId, TMVar ())])
s@(TVar t
_,TVar [(ThreadId, TMVar ())]
c) -> do

    TMVar ()
w <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (TMVar a)
newEmptyTMVarIO

    ThreadId
tid <- forall (m :: * -> *). MonadPeelIO m => m () -> m ThreadId
fork forall a b. (a -> b) -> a -> b
$
      -- Use `finally` to make sure our TMVar gets filled
      forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m ()
m (TVar t, TVar [(ThreadId, TMVar ())])
s forall (m :: * -> *) a b. MonadPeelIO m => m a -> m b -> m a
`finally` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
w ())

    -- Add the new thread to our waiting TVar
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        [(ThreadId, TMVar ())]
r <- forall a. TVar a -> STM a
readTVar TVar [(ThreadId, TMVar ())]
c
        forall a. TVar a -> a -> STM ()
writeTVar TVar [(ThreadId, TMVar ())]
c ((ThreadId
tid,TMVar ()
w)forall a. a -> [a] -> [a]
:[(ThreadId, TMVar ())]
r)

    forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
tid

forkM_ :: MonadPeelIO m
       => MState t m ()
       -> MState t m ()
forkM_ :: forall (m :: * -> *) t.
MonadPeelIO m =>
MState t m () -> MState t m ()
forkM_ MState t m ()
m = do
  ThreadId
_ <- forall (m :: * -> *) t.
MonadPeelIO m =>
MState t m () -> MState t m ThreadId
forkM MState t m ()
m
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Kill all threads in the current `MState` application.
killMState :: MonadPeelIO m => MState t m ()
killMState :: forall (m :: * -> *) t. MonadPeelIO m => MState t m ()
killMState = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t
_,TVar [(ThreadId, TMVar ())]
tv) -> do
    [(ThreadId, TMVar ())]
tms <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar [(ThreadId, TMVar ())]
tv
    -- run this in a new thread so it doesn't kill itself
    ThreadId
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ThreadId, TMVar ())]
tms
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Wait for a thread to finish
waitM :: MonadPeelIO m => ThreadId -> MState t m ()
waitM :: forall (m :: * -> *) t. MonadPeelIO m => ThreadId -> MState t m ()
waitM ThreadId
tid = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t
_,TVar [(ThreadId, TMVar ())]
c) -> do
    Maybe (TMVar ())
mw <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ThreadId
tid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. TVar a -> STM a
readTVar TVar [(ThreadId, TMVar ())]
c
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {m :: * -> *}. MonadIO m => TMVar () -> m ()
wait' Maybe (TMVar ())
mw
  where
    wait' :: TMVar () -> m ()
wait' TMVar ()
w = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        () <- forall a. TMVar a -> STM a
takeTMVar TMVar ()
w
        forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
w () -- clean up again for "waitForTermination"

--------------------------------------------------------------------------------
-- Monad instances
--------------------------------------------------------------------------------

instance (Fail.MonadFail m) => Fail.MonadFail (MState t m) where
    fail :: forall a. String -> MState t m a
fail String
str = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
str

instance (Monad m) => Monad (MState t m) where
    return :: forall a. a -> MState t m a
return a
a = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    MState t m a
m >>= :: forall a b. MState t m a -> (a -> MState t m b) -> MState t m b
>>= a -> MState t m b
k  = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> do
        a
a <- forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
t
        forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' (a -> MState t m b
k a
a) (TVar t, TVar [(ThreadId, TMVar ())])
t

instance (Functor f) => Functor (MState t f) where
    fmap :: forall a b. (a -> b) -> MState t f a -> MState t f b
fmap a -> b
f MState t f a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t f a
m (TVar t, TVar [(ThreadId, TMVar ())])
t)

instance (Applicative m, Monad m) => Applicative (MState t m) where
    pure :: forall a. a -> MState t m a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. MState t m (a -> b) -> MState t m a -> MState t m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Alternative m, Monad m) => Alternative (MState t m) where
    empty :: forall a. MState t m a
empty   = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
    MState t m a
m <|> :: forall a. MState t m a -> MState t m a -> MState t m a
<|> MState t m a
n = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
t forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
n (TVar t, TVar [(ThreadId, TMVar ())])
t

instance (MonadPlus m) => MonadPlus (MState t m) where
    mzero :: forall a. MState t m a
mzero       = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_       -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    MState t m a
m mplus :: forall a. MState t m a -> MState t m a -> MState t m a
`mplus` MState t m a
n = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
t forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
n (TVar t, TVar [(ThreadId, TMVar ())])
t

instance (MonadIO m) => MonadState t (MState t m) where
    get :: MState t m t
get     = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t
r,TVar [(ThreadId, TMVar ())]
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar t
r
    put :: t -> MState t m ()
put t
val = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t
r,TVar [(ThreadId, TMVar ())]
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar t
r t
val

instance (MonadFix m) => MonadFix (MState t m) where
    mfix :: forall a. (a -> MState t m a) -> MState t m a
mfix a -> MState t m a
f = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \a
a -> forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' (a -> MState t m a
f a
a) (TVar t, TVar [(ThreadId, TMVar ())])
s

--------------------------------------------------------------------------------
-- mtl instances
--------------------------------------------------------------------------------

instance MonadTrans (MState t) where
    lift :: forall (m :: * -> *) a. Monad m => m a -> MState t m a
lift m a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> m a
m

instance (MonadIO m) => MonadIO (MState t m) where
    liftIO :: forall a. IO a -> MState t m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance (MonadCont m) => MonadCont (MState t m) where
    callCC :: forall a b. ((a -> MState t m b) -> MState t m a) -> MState t m a
callCC (a -> MState t m b) -> MState t m a
f = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s ->
        forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC forall a b. (a -> b) -> a -> b
$ \a -> m b
c ->
            forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' ((a -> MState t m b) -> MState t m a
f (\a
a -> forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> a -> m b
c a
a)) (TVar t, TVar [(ThreadId, TMVar ())])
s

instance (MonadError e m) => MonadError e (MState t m) where
    throwError :: forall a. e -> MState t m a
throwError       = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    MState t m a
m catchError :: forall a. MState t m a -> (e -> MState t m a) -> MState t m a
`catchError` e -> MState t m a
h = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s ->
        forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
s forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
e -> forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' (e -> MState t m a
h e
e) (TVar t, TVar [(ThreadId, TMVar ())])
s

instance (MonadReader r m) => MonadReader r (MState t m) where
    ask :: MState t m r
ask       = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: forall a. (r -> r) -> MState t m a -> MState t m a
local r -> r
f MState t m a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
s)

instance (MonadWriter w m) => MonadWriter w (MState t m) where
    tell :: w -> MState t m ()
tell     = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    listen :: forall a. MState t m a -> MState t m (a, w)
listen MState t m a
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m
    pass :: forall a. MState t m (a, w -> w) -> MState t m a
pass   MState t m (a, w -> w)
m = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m (a, w -> w)
m

--------------------------------------------------------------------------------
-- MonadPeel instances
--------------------------------------------------------------------------------

instance MonadTransPeel (MState t) where
    peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
MState t n (MState t m a -> m (MState t o a))
peel = forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \MState t m a
m -> do
        a
a <- forall t (m :: * -> *) a.
MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
runMState' MState t m a
m (TVar t, TVar [(ThreadId, TMVar ())])
t
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance MonadPeelIO m => MonadPeelIO (MState t m) where
    peelIO :: forall a. MState t m (MState t m a -> IO (MState t m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO

{- $example

Example usage:

> import Control.Concurrent
> import Control.Concurrent.MState
> import Control.Monad.State
>
> type MyState a = MState Int IO a
>
> -- Expected state value: 2
> main :: IO ()
> main = print =<< execMState incTwice 0
>
> incTwice :: MyState ()
> incTwice = do
>     -- increase in the current thread
>     inc
>     -- This thread should get killed before it can "inc" our state:
>     t_id <- forkM $ do
>         delay 2
>         inc
>     -- Second increase with a small delay in a forked thread, killing the
>     -- thread above
>     forkM $ do
>         delay 1
>         inc
>         kill t_id
>     return ()
>   where
>     inc   = modifyM (+1)
>     kill  = liftIO . killThread
>     delay = liftIO . threadDelay . (*1000000) -- in seconds

-}