{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# OPTIONS_HADDOCK not-home #-}
module Effectful.Internal.Utils
( inlineBracket
, weakThreadId
, eqThreadId
, Any
, toAny
, fromAny
, IORef'
, newIORef'
, readIORef'
, writeIORef'
, MVar'
, toMVar'
, newMVar'
, readMVar'
, modifyMVar'
, modifyMVar_'
, Unique
, newUnique
, thawCallStack
) where
import Control.Concurrent.MVar
import Control.Exception
import Data.IORef
import Data.Primitive.ByteArray
import GHC.Conc.Sync (ThreadId(..))
import GHC.Exts (Any, RealWorld)
import GHC.Stack.Types (CallStack(..))
import Unsafe.Coerce (unsafeCoerce)
#if MIN_VERSION_base(4,19,0)
import GHC.Conc.Sync (fromThreadId)
#else
import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#)
#if __GLASGOW_HASKELL__ >= 904
import Data.Word
#else
import Foreign.C.Types
#endif
#endif
inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket :: forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket IO a
before a -> IO b
after a -> IO c
action = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
a
a <- IO a
before
c
r <- IO c -> IO c
forall a. IO a -> IO a
unmask (a -> IO c
action a
a) IO c -> IO b -> IO c
forall a b. IO a -> IO b -> IO a
`onException` a -> IO b
after a
a
b
_ <- a -> IO b
after a
a
c -> IO c
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure c
r
{-# INLINE inlineBracket #-}
weakThreadId :: ThreadId -> Int
#if MIN_VERSION_base(4,19,0)
weakThreadId = fromIntegral . fromThreadId
#else
weakThreadId :: ThreadId -> Int
weakThreadId (ThreadId ThreadId#
t#) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Addr# -> Word64
rts_getThreadId (ThreadId# -> Addr#
threadIdToAddr# ThreadId#
t#)
foreign import ccall unsafe "rts_getThreadId"
#if __GLASGOW_HASKELL__ >= 904
rts_getThreadId :: Addr# -> Word64
#elif __GLASGOW_HASKELL__ >= 900
rts_getThreadId :: Addr# -> CLong
#else
rts_getThreadId :: Addr# -> CInt
#endif
threadIdToAddr# :: ThreadId# -> Addr#
threadIdToAddr# :: ThreadId# -> Addr#
threadIdToAddr# = ThreadId# -> Addr#
forall a b. a -> b
unsafeCoerce#
#endif
#if __GLASGOW_HASKELL__ < 900
eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId (ThreadId t1#) (ThreadId t2#) =
eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1
foreign import ccall unsafe "effectful_eq_thread"
eq_thread :: Addr# -> Addr# -> CLong
#else
eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId = ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
(==)
#endif
toAny :: a -> Any
toAny :: forall a. a -> Any
toAny = a -> Any
forall a b. a -> b
unsafeCoerce
fromAny :: Any -> a
fromAny :: forall a. Any -> a
fromAny = Any -> a
forall a b. a -> b
unsafeCoerce
newtype IORef' a = IORef' (IORef a)
deriving IORef' a -> IORef' a -> Bool
(IORef' a -> IORef' a -> Bool)
-> (IORef' a -> IORef' a -> Bool) -> Eq (IORef' a)
forall a. IORef' a -> IORef' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. IORef' a -> IORef' a -> Bool
== :: IORef' a -> IORef' a -> Bool
$c/= :: forall a. IORef' a -> IORef' a -> Bool
/= :: IORef' a -> IORef' a -> Bool
Eq
newIORef' :: a -> IO (IORef' a)
newIORef' :: forall a. a -> IO (IORef' a)
newIORef' a
a = a
a a -> IO (IORef' a) -> IO (IORef' a)
forall a b. a -> b -> b
`seq` (IORef a -> IORef' a
forall a. IORef a -> IORef' a
IORef' (IORef a -> IORef' a) -> IO (IORef a) -> IO (IORef' a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a)
readIORef' :: IORef' a -> IO a
readIORef' :: forall a. IORef' a -> IO a
readIORef' (IORef' IORef a
var) = IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
var
writeIORef' :: IORef' a -> a -> IO ()
writeIORef' :: forall a. IORef' a -> a -> IO ()
writeIORef' (IORef' IORef a
var) a
a = a
a a -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
var a
a
newtype MVar' a = MVar' (MVar a)
deriving MVar' a -> MVar' a -> Bool
(MVar' a -> MVar' a -> Bool)
-> (MVar' a -> MVar' a -> Bool) -> Eq (MVar' a)
forall a. MVar' a -> MVar' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. MVar' a -> MVar' a -> Bool
== :: MVar' a -> MVar' a -> Bool
$c/= :: forall a. MVar' a -> MVar' a -> Bool
/= :: MVar' a -> MVar' a -> Bool
Eq
toMVar' :: MVar a -> IO (MVar' a)
toMVar' :: forall a. MVar a -> IO (MVar' a)
toMVar' MVar a
var = do
let var' :: MVar' a
var' = MVar a -> MVar' a
forall a. MVar a -> MVar' a
MVar' MVar a
var
MVar' a -> (a -> IO a) -> IO ()
forall a. MVar' a -> (a -> IO a) -> IO ()
modifyMVar_' MVar' a
var' a -> IO a
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
MVar' a -> IO (MVar' a)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MVar' a
var'
newMVar' :: a -> IO (MVar' a)
newMVar' :: forall a. a -> IO (MVar' a)
newMVar' a
a = a
a a -> IO (MVar' a) -> IO (MVar' a)
forall a b. a -> b -> b
`seq` (MVar a -> MVar' a
forall a. MVar a -> MVar' a
MVar' (MVar a -> MVar' a) -> IO (MVar a) -> IO (MVar' a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (MVar a)
forall a. a -> IO (MVar a)
newMVar a
a)
readMVar' :: MVar' a -> IO a
readMVar' :: forall a. MVar' a -> IO a
readMVar' (MVar' MVar a
var) = MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
var
modifyMVar' :: MVar' a -> (a -> IO (a, r)) -> IO r
modifyMVar' :: forall a r. MVar' a -> (a -> IO (a, r)) -> IO r
modifyMVar' (MVar' MVar a
var) a -> IO (a, r)
action = MVar a -> (a -> IO (a, r)) -> IO r
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar a
var ((a -> IO (a, r)) -> IO r) -> (a -> IO (a, r)) -> IO r
forall a b. (a -> b) -> a -> b
$ \a
a0 -> do
(a
a, r
r) <- a -> IO (a, r)
action a
a0
a
a a -> IO (a, r) -> IO (a, r)
forall a b. a -> b -> b
`seq` (a, r) -> IO (a, r)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
a, r
r)
modifyMVar_' :: MVar' a -> (a -> IO a) -> IO ()
modifyMVar_' :: forall a. MVar' a -> (a -> IO a) -> IO ()
modifyMVar_' (MVar' MVar a
var) a -> IO a
action = MVar a -> (a -> IO a) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar a
var ((a -> IO a) -> IO ()) -> (a -> IO a) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
a0 -> do
a
a <- a -> IO a
action a
a0
a
a a -> IO a -> IO a
forall a b. a -> b -> b
`seq` a -> IO a
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a
newtype Unique = Unique (MutableByteArray RealWorld)
instance Eq Unique where
Unique MutableByteArray RealWorld
a == :: Unique -> Unique -> Bool
== Unique MutableByteArray RealWorld
b = MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
a MutableByteArray RealWorld
b
newUnique :: IO Unique
newUnique :: IO Unique
newUnique = MutableByteArray RealWorld -> Unique
Unique (MutableByteArray RealWorld -> Unique)
-> IO (MutableByteArray RealWorld) -> IO Unique
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (MutableByteArray (PrimState IO))
forall (m :: Type -> Type).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
0
thawCallStack :: CallStack -> CallStack
thawCallStack :: CallStack -> CallStack
thawCallStack = \case
FreezeCallStack CallStack
cs -> CallStack
cs
CallStack
cs -> CallStack
cs