{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Monad.STM (
STM,
atomically,
#ifdef __GLASGOW_HASKELL__
retry,
orElse,
check,
#endif
throwSTM,
catchSTM
) where
#ifdef __GLASGOW_HASKELL__
#if ! (MIN_VERSION_base(4,3,0))
import GHC.Conc hiding (catchSTM)
import Control.Monad ( MonadPlus(..) )
import Control.Exception
#else
import GHC.Conc
#endif
import GHC.Exts
import Control.Monad.Fix
#else
import Control.Sequential.STM
#endif
#ifdef __GLASGOW_HASKELL__
#if ! (MIN_VERSION_base(4,3,0))
import Control.Applicative
import Control.Monad (ap)
#endif
#endif
#if !MIN_VERSION_base(4,17,0)
import Control.Monad (liftM2)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid (..))
#endif
#endif
#ifdef __GLASGOW_HASKELL__
#if ! (MIN_VERSION_base(4,3,0))
instance MonadPlus STM where
mzero = retry
mplus = orElse
instance Applicative STM where
pure = return
(<*>) = ap
instance Alternative STM where
empty = retry
(<|>) = orElse
#endif
check :: Bool -> STM ()
check :: Bool -> STM ()
check Bool
b = if Bool
b then () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return () else STM ()
forall a. STM a
retry
#endif
#if ! (MIN_VERSION_base(4,3,0))
catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (STM m) handler = STM $ catchSTM# m handler'
where
handler' e = case fromException e of
Just e' -> case handler e' of STM m' -> m'
Nothing -> raiseIO# e
throwSTM :: Exception e => e -> STM a
throwSTM e = STM $ raiseIO# (toException e)
#endif
data STMret a = STMret (State# RealWorld) a
liftSTM :: STM a -> State# RealWorld -> STMret a
liftSTM :: forall a. STM a -> State# RealWorld -> STMret a
liftSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) = \State# RealWorld
s -> case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s of (# State# RealWorld
s', a
r #) -> State# RealWorld -> a -> STMret a
forall a. State# RealWorld -> a -> STMret a
STMret State# RealWorld
s' a
r
instance MonadFix STM where
mfix :: forall a. (a -> STM a) -> STM a
mfix a -> STM a
k = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
let ans :: STMret a
ans = STM a -> State# RealWorld -> STMret a
forall a. STM a -> State# RealWorld -> STMret a
liftSTM (a -> STM a
k a
r) State# RealWorld
s
STMret State# RealWorld
_ a
r = STMret a
ans
in case STMret a
ans of STMret State# RealWorld
s' a
x -> (# State# RealWorld
s', a
x #)
#if !MIN_VERSION_base(4,17,0)
instance Semigroup a => Semigroup (STM a) where
(<>) = liftM2 (<>)
instance Monoid a => Monoid (STM a) where
mempty = return mempty
#if !MIN_VERSION_base(4,13,0)
mappend = liftM2 mappend
#endif
#endif