{-# 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.Fix
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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TVar [(ThreadId, TMVar ())] -> IO ())
-> TVar [(ThreadId, TMVar ())]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (TVar [(ThreadId, TMVar ())] -> STM ())
-> TVar [(ThreadId, TMVar ())]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((ThreadId, TMVar ()) -> STM ())
-> [(ThreadId, TMVar ())] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar (TMVar () -> STM ())
-> ((ThreadId, TMVar ()) -> TMVar ())
-> (ThreadId, TMVar ())
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId, TMVar ()) -> TMVar ()
forall a b. (a, b) -> b
snd) ([(ThreadId, TMVar ())] -> STM ())
-> (TVar [(ThreadId, TMVar ())] -> STM [(ThreadId, TMVar ())])
-> TVar [(ThreadId, TMVar ())]
-> STM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< TVar [(ThreadId, TMVar ())] -> STM [(ThreadId, TMVar ())]
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') <- Bool -> MState t m a -> t -> m (a, Maybe 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'' -> (a, t) -> m (a, t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, t
t'')
      Maybe t
_ -> m (a, 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 <- IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
    TMVar ()
myM <- IO (TMVar ()) -> m (TMVar ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO
    TVar t
ref <- IO (TVar t) -> m (TVar t)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar t) -> m (TVar t)) -> IO (TVar t) -> m (TVar t)
forall a b. (a -> b) -> a -> b
$ t -> IO (TVar t)
forall a. a -> IO (TVar a)
newTVarIO t
t
    TVar [(ThreadId, TMVar ())]
c   <- IO (TVar [(ThreadId, TMVar ())]) -> m (TVar [(ThreadId, TMVar ())])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar [(ThreadId, TMVar ())])
 -> m (TVar [(ThreadId, TMVar ())]))
-> IO (TVar [(ThreadId, TMVar ())])
-> m (TVar [(ThreadId, TMVar ())])
forall a b. (a -> b) -> a -> b
$ [(ThreadId, TMVar ())] -> IO (TVar [(ThreadId, TMVar ())])
forall a. a -> IO (TVar a)
newTVarIO [(ThreadId
myI, TMVar ()
myM)]
    a
a   <- MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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) m a -> m () -> m a
forall (m :: * -> *) a b. MonadPeelIO m => m a -> m b -> m a
`finally` IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
myM ())
    if Bool
b then do
      -- wait before getting the final state
      TVar [(ThreadId, TMVar ())] -> m ()
forall (m :: * -> *).
MonadIO m =>
TVar [(ThreadId, TMVar ())] -> m ()
waitForTermination TVar [(ThreadId, TMVar ())]
c
      t
t'  <- IO t -> m t
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO t -> m t) -> IO t -> m t
forall a b. (a -> b) -> a -> b
$ TVar t -> IO t
forall a. TVar a -> IO a
readTVarIO TVar t
ref
      (a, Maybe t) -> m (a, Maybe t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, t -> Maybe t
forall a. a -> Maybe a
Just t
t')
     else
      -- don't wait for other threads
      (a, Maybe t) -> m (a, Maybe t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Maybe t
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 = Bool -> MState t m a -> t -> m (a, Maybe 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 m (a, Maybe t) -> ((a, Maybe t) -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> ((a, Maybe t) -> a) -> (a, Maybe t) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe t) -> a
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 = MState t m a -> t -> m (a, t)
forall (m :: * -> *) t a.
MonadPeelIO m =>
MState t m a -> t -> m (a, t)
runMState MState t m a
m t
t m (a, t) -> ((a, t) -> m t) -> m t
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> m t
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> m t) -> ((a, t) -> t) -> (a, t) -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, t) -> t
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b
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 (m (a, t) -> n (b, t)) -> m (a, t) -> n (b, t)
forall a b. (a -> b) -> a -> b
$ do
        a
a <- MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 <- IO t -> m t
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO t -> m t) -> IO t -> m t
forall a b. (a -> b) -> a -> b
$ TVar t -> IO t
forall a. TVar a -> IO a
readTVarIO TVar t
r
        (a, t) -> m (a, t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,t
v)
    IO () -> n ()
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> n ()) -> (STM () -> IO ()) -> STM () -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> n ()) -> STM () -> n ()
forall a b. (a -> b) -> a -> b
$ TVar t -> t -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar t
r t
v'
    b -> n b
forall a. a -> n a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> n b) -> MState t n b
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> do
    b
b <- m a -> n b
f (m a -> n b) -> m a -> n b
forall a b. (a -> b) -> a -> b
$ MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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
    b -> n b
forall a. a -> n a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t
t,TVar [(ThreadId, TMVar ())]
_) ->
    IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (STM a -> IO a) -> STM a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ do
        t
v <- TVar t -> STM t
forall a. TVar a -> STM a
readTVar TVar t
t
        let (a
a,t
v') = t -> (a, t)
f t
v
        TVar t -> t -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar t
t t
v'
        a -> STM a
forall a. a -> STM a
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 = (t -> ((), t)) -> MState t m ()
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 <- m (m () -> IO (m ()))
forall a. m (m a -> IO (m a))
forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
  IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> m ThreadId) -> IO () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ m () -> IO (m ())
k m ()
m IO (m ()) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ThreadId)
-> MState t m ThreadId
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m ThreadId)
 -> MState t m ThreadId)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ThreadId)
-> MState t m ThreadId
forall a b. (a -> b) -> a -> b
$ \s :: (TVar t, TVar [(ThreadId, TMVar ())])
s@(TVar t
_,TVar [(ThreadId, TMVar ())]
c) -> do

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

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

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

    ThreadId -> m ThreadId
forall a. a -> m a
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
_ <- MState t m () -> MState t m ThreadId
forall (m :: * -> *) t.
MonadPeelIO m =>
MState t m () -> MState t m ThreadId
forkM MState t m ()
m
  () -> MState t m ()
forall a. a -> MState t m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ())
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall a b. (a -> b) -> a -> b
$ \(TVar t
_,TVar [(ThreadId, TMVar ())]
tv) -> do
    [(ThreadId, TMVar ())]
tms <- IO [(ThreadId, TMVar ())] -> m [(ThreadId, TMVar ())]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(ThreadId, TMVar ())] -> m [(ThreadId, TMVar ())])
-> IO [(ThreadId, TMVar ())] -> m [(ThreadId, TMVar ())]
forall a b. (a -> b) -> a -> b
$ TVar [(ThreadId, TMVar ())] -> IO [(ThreadId, TMVar ())]
forall a. TVar a -> IO a
readTVarIO TVar [(ThreadId, TMVar ())]
tv
    -- run this in a new thread so it doesn't kill itself
    ThreadId
_ <- IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> m ThreadId) -> IO () -> m ThreadId
forall a b. (a -> b) -> a -> b
$
      ((ThreadId, TMVar ()) -> IO ()) -> [(ThreadId, TMVar ())] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread (ThreadId -> IO ())
-> ((ThreadId, TMVar ()) -> ThreadId)
-> (ThreadId, TMVar ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId, TMVar ()) -> ThreadId
forall a b. (a, b) -> a
fst) [(ThreadId, TMVar ())]
tms
    () -> m ()
forall a. a -> m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ())
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall a b. (a -> b) -> a -> b
$ \(TVar t
_,TVar [(ThreadId, TMVar ())]
c) -> do
    Maybe (TMVar ())
mw <- IO (Maybe (TMVar ())) -> m (Maybe (TMVar ()))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (TMVar ())) -> m (Maybe (TMVar ())))
-> (STM (Maybe (TMVar ())) -> IO (Maybe (TMVar ())))
-> STM (Maybe (TMVar ()))
-> m (Maybe (TMVar ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe (TMVar ())) -> IO (Maybe (TMVar ()))
forall a. STM a -> IO a
atomically (STM (Maybe (TMVar ())) -> m (Maybe (TMVar ())))
-> STM (Maybe (TMVar ())) -> m (Maybe (TMVar ()))
forall a b. (a -> b) -> a -> b
$ do
        ThreadId -> [(ThreadId, TMVar ())] -> Maybe (TMVar ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ThreadId
tid ([(ThreadId, TMVar ())] -> Maybe (TMVar ()))
-> STM [(ThreadId, TMVar ())] -> STM (Maybe (TMVar ()))
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TVar [(ThreadId, TMVar ())] -> STM [(ThreadId, TMVar ())]
forall a. TVar a -> STM a
readTVar TVar [(ThreadId, TMVar ())]
c
    m () -> (TMVar () -> m ()) -> Maybe (TMVar ()) -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) TMVar () -> m ()
forall {m :: * -> *}. MonadIO m => TMVar () -> m ()
wait' Maybe (TMVar ())
mw
  where
    wait' :: TMVar () -> m ()
wait' TMVar ()
w = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (STM () -> IO ()) -> STM () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        () <- TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
w
        TMVar () -> () -> STM ()
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
str

instance (Monad m) => Monad (MState t m) where
    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  = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> do
        a
a <- MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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
        MState t m b -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m b
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> f b) -> MState t f b
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> f b) -> MState t f b)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> f b) -> MState t f b
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (MState t f a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> f a
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 a
a = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    <*> :: forall a b. MState t m (a -> b) -> MState t m a -> MState t m 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   = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_ -> m a
forall a. m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 m a -> m a -> m a
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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       = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
_       -> m a
forall a. m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 m a -> m a -> m a
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 (MonadIO m) => MonadState t (MState t m) where
    get :: MState t m t
get     = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m t) -> MState t m t
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m t) -> MState t m t)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m t) -> MState t m t
forall a b. (a -> b) -> a -> b
$ \(TVar t
r,TVar [(ThreadId, TMVar ())]
_) -> IO t -> m t
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO t -> m t) -> IO t -> m t
forall a b. (a -> b) -> a -> b
$ TVar t -> IO t
forall a. TVar a -> IO a
readTVarIO TVar t
r
    put :: t -> MState t m ()
put t
val = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ())
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m ()) -> MState t m ()
forall a b. (a -> b) -> a -> b
$ \(TVar t
r,TVar [(ThreadId, TMVar ())]
_) -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (STM () -> IO ()) -> STM () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar t -> t -> STM ()
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> (a -> m a) -> m a
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> m a) -> m a) -> (a -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \a
a -> MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
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 = m a -> MState t m a
forall (m :: * -> *) a. Monad m => m a -> MState t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> MState t m a) -> (IO a -> m a) -> IO a -> MState t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s ->
        ((a -> m b) -> m a) -> m a
forall a b. ((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((a -> m b) -> m a) -> m a) -> ((a -> m b) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \a -> m b
c ->
            MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
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 -> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m b) -> MState t m b
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       = m a -> MState t m a
forall (m :: * -> *) a. Monad m => m a -> MState t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> MState t m a) -> (e -> m a) -> e -> MState t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall a. e -> m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s ->
        MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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 m a -> (e -> m a) -> m a
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
e -> MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
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       = m r -> MState t m r
forall (m :: * -> *) a. Monad m => m a -> MState t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
s -> (r -> r) -> m a -> m a
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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)

instance (MonadWriter w m) => MonadWriter w (MState t m) where
    tell :: w -> MState t m ()
tell     = m () -> MState t m ()
forall (m :: * -> *) a. Monad m => m a -> MState t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MState t m ()) -> (w -> m ()) -> w -> MState t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m (a, w))
-> MState t m (a, w)
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m (a, w))
 -> MState t m (a, w))
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m (a, w))
-> MState t m (a, w)
forall a b. (a -> b) -> a -> b
$ m a -> m (a, w)
forall a. m a -> m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m a -> m (a, w))
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a)
-> (TVar t, TVar [(ThreadId, TMVar ())])
-> m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m a
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 = ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
forall a b. (a -> b) -> a -> b
$ m (a, w -> w) -> m a
forall a. m (a, w -> w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass   (m (a, w -> w) -> m a)
-> ((TVar t, TVar [(ThreadId, TMVar ())]) -> m (a, w -> w))
-> (TVar t, TVar [(ThreadId, TMVar ())])
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MState t m (a, w -> w)
-> (TVar t, TVar [(ThreadId, TMVar ())]) -> m (a, w -> w)
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 = ((TVar t, TVar [(ThreadId, TMVar ())])
 -> n (MState t m a -> m (MState t o a)))
-> MState t n (MState t m a -> m (MState t o a))
forall t (m :: * -> *) a.
((TVar t, TVar [(ThreadId, TMVar ())]) -> m a) -> MState t m a
MState (((TVar t, TVar [(ThreadId, TMVar ())])
  -> n (MState t m a -> m (MState t o a)))
 -> MState t n (MState t m a -> m (MState t o a)))
-> ((TVar t, TVar [(ThreadId, TMVar ())])
    -> n (MState t m a -> m (MState t o a)))
-> MState t n (MState t m a -> m (MState t o a))
forall a b. (a -> b) -> a -> b
$ \(TVar t, TVar [(ThreadId, TMVar ())])
t -> (MState t m a -> m (MState t o a))
-> n (MState t m a -> m (MState t o a))
forall a. a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return ((MState t m a -> m (MState t o a))
 -> n (MState t m a -> m (MState t o a)))
-> (MState t m a -> m (MState t o a))
-> n (MState t m a -> m (MState t o a))
forall a b. (a -> b) -> a -> b
$ \MState t m a
m -> do
        a
a <- MState t m a -> (TVar t, TVar [(ThreadId, TMVar ())]) -> m 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
        MState t o a -> m (MState t o a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (MState t o a -> m (MState t o a))
-> MState t o a -> m (MState t o a)
forall a b. (a -> b) -> a -> b
$ a -> MState t o a
forall a. a -> MState t o a
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 = m (m (MState t m a) -> IO (m (MState t m a)))
-> MState t m (MState t m a -> IO (MState t m a))
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 m (m (MState t m a) -> IO (m (MState t m a)))
forall a. m (m a -> IO (m a))
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

-}