diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 6dac602..3ab32d0 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -82,6 +82,8 @@ library exposed-modules: Effectful Effectful.Dispatch.Dynamic Effectful.Dispatch.Static + Effectful.Dispatch.Static.Primitive + Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static Effectful.Fail diff --git a/effectful-core/src/Effectful/Dispatch/Dynamic.hs b/effectful-core/src/Effectful/Dispatch/Dynamic.hs index e8fabc9..98b4d52 100644 --- a/effectful-core/src/Effectful/Dispatch/Dynamic.hs +++ b/effectful-core/src/Effectful/Dispatch/Dynamic.hs @@ -356,7 +356,7 @@ localUnliftIO (LocalEnv les) strategy k = case strategy of -- -- @'Eff' localEs a -> 'Eff' localEs b@ -- --- /Note:/ the computation must not run its argument in a separate thread, +-- /Note:/ the computation must not run its argument in a different thread, -- attempting to do so will result in a runtime error. withLiftMap :: (HasCallStack, SuffixOf es handlerEs) @@ -380,7 +380,7 @@ withLiftMap !_ k = unsafeEff $ \es -> do -- -- @'Eff' localEs a -> 'Eff' localEs b@ -- --- /Note:/ the computation must not run its argument in a separate thread, +-- /Note:/ the computation must not run its argument in a different thread, -- attempting to do so will result in a runtime error. -- -- Useful e.g. for lifting the unmasking function in diff --git a/effectful-core/src/Effectful/Dispatch/Static.hs b/effectful-core/src/Effectful/Dispatch/Static.hs index 024b2da..b61d298 100644 --- a/effectful-core/src/Effectful/Dispatch/Static.hs +++ b/effectful-core/src/Effectful/Dispatch/Static.hs @@ -24,41 +24,18 @@ module Effectful.Dispatch.Static -- ** Unlifts , seqUnliftIO , concUnliftIO + , unsafeSeqUnliftIO + , unsafeConcUnliftIO -- ** Utils , unEff , unsafeEff , unsafeEff_ , unsafeLiftMapIO - , unsafeUnliftIO - - -- * Primitive API - , Env - , Relinker(..) - , dummyRelinker - - -- ** Representation of effects - , EffectRep - - -- ** Operations - , emptyEnv - , cloneEnv - , forkEnv - , sizeEnv - , checkSizeEnv - - -- ** Extending and shrinking - , unsafeConsEnv - , unsafeTailEnv - - -- ** Data retrieval and update - , getEnv - , putEnv - , stateEnv - , modifyEnv ) where -import Effectful.Internal.Env +import GHC.Stack (HasCallStack) + import Effectful.Internal.Monad -- $intro @@ -180,27 +157,40 @@ import Effectful.Internal.Monad -- -- @'Eff' es a -> 'Eff' es b@ -- --- This function is __unsafe__ because: +-- /Note:/ the computation must not run its argument in a separate thread, +-- attempting to do so will result in a runtime error. -- --- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' --- computations. --- --- - The 'IO' computation must not run its argument in a separate thread, but --- it's not checked anywhere. -unsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b -unsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es) +-- This function is __unsafe__ because it can be used to introduce arbitrary +-- 'IO' actions into pure 'Eff' computations. +unsafeLiftMapIO :: HasCallStack => (IO a -> IO b) -> Eff es a -> Eff es b +unsafeLiftMapIO f m = unsafeEff $ \es -> do + seqUnliftIO es $ \unlift -> f (unlift m) --- | Utility for running 'Eff' computations locally in the 'IO' monad. +-- | Create an unlifting function with the 'SeqUnlift' strategy. -- --- This function is __unsafe__ because: +-- This function is __unsafe__ because it can be used to introduce arbitrary +-- 'IO' actions into pure 'Eff' computations. +unsafeSeqUnliftIO + :: HasCallStack + => ((forall r. Eff es r -> IO r) -> IO a) + -- ^ Continuation with the unlifting function in scope. + -> Eff es a +unsafeSeqUnliftIO k = unsafeEff $ \es -> do + seqUnliftIO es k + +-- | Create an unlifting function with the 'ConcUnlift' strategy. -- --- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' --- computations. --- --- - Unlifted 'Eff' computations must not be run in a thread distinct from the --- caller of 'unsafeUnliftIO', but it's not checked anywhere. -unsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a -unsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es) +-- This function is __unsafe__ because it can be used to introduce arbitrary +-- 'IO' actions into pure 'Eff' computations. +unsafeConcUnliftIO + :: HasCallStack + => Persistence + -> Limit + -> ((forall r. Eff es r -> IO r) -> IO a) + -- ^ Continuation with the unlifting function in scope. + -> Eff es a +unsafeConcUnliftIO persistence limit k = unsafeEff $ \es -> do + concUnliftIO es persistence limit k -- $setup -- >>> import Effectful diff --git a/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs b/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs new file mode 100644 index 0000000..e8d3302 --- /dev/null +++ b/effectful-core/src/Effectful/Dispatch/Static/Primitive.hs @@ -0,0 +1,36 @@ +-- | Primitive API for statically dispatched effects. +-- +-- /Warning:/ this module exposes internal implementation details of the 'Eff' +-- monad. Most of the time functions from "Effectful.Dispatch.Static" are +-- sufficient and safer to use. +module Effectful.Dispatch.Static.Primitive + ( -- * The environment + Env + + -- ** Relinker + , Relinker(..) + , dummyRelinker + + -- ** Representation of effects + , EffectRep + + -- ** Extending and shrinking + , unsafeConsEnv + , unsafeTailEnv + + -- ** Data retrieval and update + , getEnv + , putEnv + , stateEnv + , modifyEnv + + -- ** Utils + , emptyEnv + , cloneEnv + , forkEnv + , sizeEnv + , checkSizeEnv + ) where + +import Effectful.Internal.Env +import Effectful.Internal.Monad diff --git a/effectful-core/src/Effectful/Dispatch/Static/Unsafe.hs b/effectful-core/src/Effectful/Dispatch/Static/Unsafe.hs new file mode 100644 index 0000000..78512c2 --- /dev/null +++ b/effectful-core/src/Effectful/Dispatch/Static/Unsafe.hs @@ -0,0 +1,40 @@ +module Effectful.Dispatch.Static.Unsafe + ( reallyUnsafeLiftMapIO + , reallyUnsafeUnliftIO + ) where + +import Effectful.Internal.Monad + +-- | Utility for lifting 'IO' computations of type +-- +-- @'IO' a -> 'IO' b@ +-- +-- to +-- +-- @'Eff' es a -> 'Eff' es b@ +-- +-- This function is __highly unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- computations. +-- +-- - The 'IO' computation must not run its argument in a different thread, but +-- it's not checked anywhere. +-- +-- __If you disregard the second point, segmentation faults await.__ +reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b +reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es) + +-- | Create an unlifting function. +-- +-- This function is __highly unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- computations. +-- +-- - Unlifted 'Eff' computations must not be run in a thread distinct from the +-- caller of 'reallyUnsafeUnliftIO', but it's not checked anywhere. +-- +-- __If you disregard the second point, segmentation faults await.__ +reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a +reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es) diff --git a/effectful-core/src/Effectful/Error/Static.hs b/effectful-core/src/Effectful/Error/Static.hs index 2d3f70c..0b70ab2 100644 --- a/effectful-core/src/Effectful/Error/Static.hs +++ b/effectful-core/src/Effectful/Error/Static.hs @@ -102,6 +102,7 @@ import GHC.Stack import Effectful import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive import Effectful.Internal.Utils -- | Provide the ability to handle errors of type @e@. diff --git a/effectful-core/src/Effectful/Internal/Env.hs b/effectful-core/src/Effectful/Internal/Env.hs index f994967..6fb888e 100644 --- a/effectful-core/src/Effectful/Internal/Env.hs +++ b/effectful-core/src/Effectful/Internal/Env.hs @@ -29,7 +29,7 @@ module Effectful.Internal.Env , checkSizeEnv -- ** Extending and shrinking - , veryUnsafeConsEnv + , reallyUnsafeConsEnv , unsafeTailEnv -- ** Data retrieval and update @@ -52,12 +52,17 @@ import Effectful.Internal.Utils type role Env nominal --- | A strict (WHNF), thread local, mutable, extensible record indexed by types +-- | A strict (WHNF), __thread local__, mutable, extensible record indexed by types -- of kind 'Effect'. -- -- Supports forking, i.e. introduction of local branches for encapsulation of -- data specific to effect handlers. -- +-- __Warning: the environment is a mutable data structure and cannot be simultaneously used from multiple threads under any circumstances.__ +-- +-- In order to pass it to a different thread, you need to perform a deep copy +-- with the 'cloneEnv' funtion. +-- -- Offers very good performance characteristics: -- -- - Extending: /O(1)/ (amortized). @@ -68,6 +73,7 @@ type role Env nominal -- -- - Modification of a specific element: /O(1)/. -- +-- -- Here's an example of how the environment might look: -- -- @ @@ -182,6 +188,8 @@ emptyEnv :: IO (Env '[]) emptyEnv = Env NoFork <$> emptyEnvRef <*> newForkIdGen -- | Clone the environment. +-- +-- Mostly used to pass the environment to a different thread. cloneEnv :: Env es -> IO (Env es) cloneEnv (Env NoFork gref0 gen0) = do EnvRef n es0 fs0 <- readIORef gref0 @@ -361,10 +369,12 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do -- - The @rep@ type variable is unrestricted, so it's possible to put in a -- different data type than the one retrieved later. -- --- - It renders the input 'Env' unusable until the corresponding 'unsafeTailEnv' --- call is made, but it's not checked anywhere. -veryUnsafeConsEnv :: rep e -> Relinker rep e -> Env es -> IO (Env (e : es)) -veryUnsafeConsEnv e f (Env fork gref gen) = case fork of +-- - It renders the input 'Env' __unusable__ until the corresponding +-- 'unsafeTailEnv' call is made, but it's not checked anywhere. +-- +-- __If you disregard the above, segmentation faults await.__ +reallyUnsafeConsEnv :: rep e -> Relinker rep e -> Env es -> IO (Env (e : es)) +reallyUnsafeConsEnv e f (Env fork gref gen) = case fork of NoFork -> do extendEnvRef gref pure $ Env NoFork gref gen @@ -394,13 +404,15 @@ veryUnsafeConsEnv e f (Env fork gref gen) = case fork of doubleCapacity :: Int -> Int doubleCapacity n = max 1 n * 2 -{-# NOINLINE veryUnsafeConsEnv #-} +{-# NOINLINE reallyUnsafeConsEnv #-} -- | Shrink the environment by one data type (in place). Makes sure the size of -- the environment is as expected. -- -- This function is __highly unsafe__ because it renders the input 'Env' --- unusable, but it's not checked anywhere. +-- __unusable__, but it's not checked anywhere. +-- +-- __If you disregard the above, segmentation faults await.__ unsafeTailEnv :: Int -> Env (e : es) -> IO () unsafeTailEnv len (Env fork gref _) = case fork of NoFork -> shrinkEnvRef len gref diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index 8968f07..67fc043 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -475,13 +475,15 @@ localStaticRep f m = unsafeEff $ \es -> do -- This function is __highly unsafe__ because it renders the input 'Env' -- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not -- checked anywhere. +-- +-- __If you disregard the above, segmentation faults await.__ unsafeConsEnv :: EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es)) -unsafeConsEnv = veryUnsafeConsEnv +unsafeConsEnv = reallyUnsafeConsEnv -- | Extract a specific representation of the effect from the environment. getEnv :: e :> es => Env es -> IO (EffectRep (DispatchOf e) e) diff --git a/effectful-core/src/Effectful/State/Static/Shared.hs b/effectful-core/src/Effectful/State/Static/Shared.hs index d3fc7a5..74d8584 100644 --- a/effectful-core/src/Effectful/State/Static/Shared.hs +++ b/effectful-core/src/Effectful/State/Static/Shared.hs @@ -45,6 +45,7 @@ import Control.Concurrent.MVar import Effectful import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive -- | Provide access to a strict (WHNF), shared, mutable value of type @s@. data State s :: Effect diff --git a/effectful-core/src/Effectful/Writer/Static/Local.hs b/effectful-core/src/Effectful/Writer/Static/Local.hs index f43345b..a79ca5b 100644 --- a/effectful-core/src/Effectful/Writer/Static/Local.hs +++ b/effectful-core/src/Effectful/Writer/Static/Local.hs @@ -31,6 +31,7 @@ import Control.Exception (onException, mask) import Effectful import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive -- | Provide access to a strict (WHNF), thread local, write only value of type -- @w@. diff --git a/effectful-core/src/Effectful/Writer/Static/Shared.hs b/effectful-core/src/Effectful/Writer/Static/Shared.hs index 4916fec..1a46466 100644 --- a/effectful-core/src/Effectful/Writer/Static/Shared.hs +++ b/effectful-core/src/Effectful/Writer/Static/Shared.hs @@ -32,6 +32,7 @@ import Control.Exception (onException, uninterruptibleMask) import Effectful import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive -- | Provide access to a strict (WHNF), shared, write only value of type @w@. data Writer w :: Effect diff --git a/effectful/src/Effectful/Concurrent.hs b/effectful/src/Effectful/Concurrent.hs index 6df7476..f7e182a 100644 --- a/effectful/src/Effectful/Concurrent.hs +++ b/effectful/src/Effectful/Concurrent.hs @@ -70,6 +70,8 @@ import qualified GHC.Conc as GHC import Effectful import Effectful.Concurrent.Effect import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Static.Unsafe ---------------------------------------- -- Basic concurrency operations @@ -99,9 +101,7 @@ forkIOWithUnmask :: Concurrent :> es => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId -forkIOWithUnmask f = unsafeEff $ \es -> do - esF <- cloneEnv es - C.forkIOWithUnmask $ \unmask -> unEff (f $ unsafeLiftMapIO unmask) esF +forkIOWithUnmask = liftForkWithUnmask C.forkIOWithUnmask -- | Lifted 'C.killThread'. killThread :: Concurrent :> es => C.ThreadId -> Eff es () @@ -126,9 +126,7 @@ forkOnWithUnmask => Int -> ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId -forkOnWithUnmask n f = unsafeEff $ \es -> do - esF <- cloneEnv es - C.forkOnWithUnmask n $ \unmask -> unEff (f $ unsafeLiftMapIO unmask) esF +forkOnWithUnmask n = liftForkWithUnmask (C.forkOnWithUnmask n) -- | Lifted 'C.getNumCapabilities'. getNumCapabilities :: Concurrent :> es => Eff es Int @@ -192,9 +190,7 @@ forkOSWithUnmask :: Concurrent :> es => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId -forkOSWithUnmask f = unsafeEff $ \es -> do - esF <- cloneEnv es - C.forkOSWithUnmask $ \unmask -> unEff (f $ unsafeLiftMapIO unmask) esF +forkOSWithUnmask = liftForkWithUnmask C.forkOSWithUnmask -- | Lifted 'C.isCurrentThreadBound'. isCurrentThreadBound :: Concurrent :> es => Eff es Bool @@ -218,3 +214,15 @@ runInUnboundThread k = unsafeEff $ \es -> do -- | Lifted 'C.mkWeakThreadId'. mkWeakThreadId :: Concurrent :> es => C.ThreadId -> Eff es (Weak C.ThreadId) mkWeakThreadId = unsafeEff_ . C.mkWeakThreadId + +---------------------------------------- +-- Helpers + +liftForkWithUnmask + :: (((forall c. IO c -> IO c) -> IO a) -> IO C.ThreadId) + -> ((forall c. Eff es c -> Eff es c) -> Eff es a) + -> Eff es C.ThreadId +liftForkWithUnmask fork action = unsafeEff $ \es -> do + esF <- cloneEnv es + -- Unmask never runs its argument in a different thread. + fork $ \unmask -> unEff (action $ reallyUnsafeLiftMapIO unmask) esF diff --git a/effectful/src/Effectful/Concurrent/Async.hs b/effectful/src/Effectful/Concurrent/Async.hs index c824b62..f77ed0e 100644 --- a/effectful/src/Effectful/Concurrent/Async.hs +++ b/effectful/src/Effectful/Concurrent/Async.hs @@ -87,6 +87,8 @@ import qualified UnliftIO.Internals.Async as I import Effectful import Effectful.Concurrent.Effect import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Static.Unsafe -- | Lifted 'A.async'. async :: Concurrent :> es => Eff es a -> Eff es (Async a) @@ -524,7 +526,8 @@ liftAsyncWithUnmask -> Eff es (Async a) liftAsyncWithUnmask fork action = unsafeEff $ \es -> do esA <- cloneEnv es - fork $ \unmask -> unEff (action $ unsafeLiftMapIO unmask) esA + -- Unmask never runs its argument in a different thread. + fork $ \unmask -> unEff (action $ reallyUnsafeLiftMapIO unmask) esA liftWithAsync :: (IO a -> (Async a -> IO b) -> IO b) @@ -543,5 +546,6 @@ liftWithAsyncWithUnmask -> Eff es b liftWithAsyncWithUnmask withA action k = unsafeEff $ \es -> do esA <- cloneEnv es - withA (\unmask -> unEff (action $ unsafeLiftMapIO unmask) esA) + -- Unmask never runs its argument in a different thread. + withA (\unmask -> unEff (action $ reallyUnsafeLiftMapIO unmask) esA) (\a -> unEff (k a) es) diff --git a/effectful/src/Effectful/Concurrent/MVar.hs b/effectful/src/Effectful/Concurrent/MVar.hs index f61a9a4..debab45 100644 --- a/effectful/src/Effectful/Concurrent/MVar.hs +++ b/effectful/src/Effectful/Concurrent/MVar.hs @@ -34,6 +34,8 @@ import qualified Control.Concurrent.MVar as M import Effectful import Effectful.Concurrent.Effect import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Static.Unsafe -- | Lifted 'M.newEmptyMVar'. newEmptyMVar :: Concurrent :> es => Eff es (MVar a) @@ -77,35 +79,36 @@ tryReadMVar = unsafeEff_ . M.tryReadMVar -- | Lifted 'M.withMVar'. withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b -withMVar var f = unsafeUnliftIO $ \unlift -> do +withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVar var $ unlift . f -- | Lifted 'M.withMVarMasked'. withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b -withMVarMasked var f = unsafeUnliftIO $ \unlift -> do +withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVarMasked var $ unlift . f -- | Lifted 'M.modifyMVar_'. modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () -modifyMVar_ var f = unsafeUnliftIO $ \unlift -> do +modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar_ var $ unlift . f -- | Lifted 'M.modifyMVar'. modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b -modifyMVar var f = unsafeUnliftIO $ \unlift -> do +modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar var $ unlift . f -- | Lifted 'M.modifyMVarMasked_'. modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () -modifyMVarMasked_ var f = unsafeUnliftIO $ \unlift -> do +modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked_ var $ unlift . f -- | Lifted 'M.modifyMVarMasked'. modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b -modifyMVarMasked var f = unsafeUnliftIO $ \unlift -> do +modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked var $ unlift . f -- | Lifted 'M.mkWeakMVar'. mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) -mkWeakMVar var f = unsafeUnliftIO $ \unlift -> do - M.mkWeakMVar var $ unlift f +mkWeakMVar var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + M.mkWeakMVar var . unEff f =<< cloneEnv es diff --git a/effectful/src/Effectful/Concurrent/STM.hs b/effectful/src/Effectful/Concurrent/STM.hs index c761982..c70334e 100644 --- a/effectful/src/Effectful/Concurrent/STM.hs +++ b/effectful/src/Effectful/Concurrent/STM.hs @@ -97,53 +97,56 @@ import GHC.Natural (Natural) import Effectful import Effectful.Concurrent.Effect import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive --- | Lifted version of 'STM.atomically' +-- | Lifted version of 'STM.atomically'. atomically :: Concurrent :> es => STM a -> Eff es a atomically = unsafeEff_ . STM.atomically --- | Lifted version of 'STM.newTVarIO' +-- | Lifted version of 'STM.newTVarIO'. newTVarIO :: Concurrent :> es => a -> Eff es (TVar a) newTVarIO = unsafeEff_ . STM.newTVarIO --- | Lifted version of 'STM.readTVarIO' +-- | Lifted version of 'STM.readTVarIO'. readTVarIO :: Concurrent :> es => TVar a -> Eff es a readTVarIO = unsafeEff_ . STM.readTVarIO --- | Lifted version of 'STM.registerDelay' +-- | Lifted version of 'STM.registerDelay'. registerDelay :: Concurrent :> es => Int -> Eff es (TVar Bool) registerDelay = unsafeEff_ . STM.registerDelay --- | Lifted version of 'STM.mkWeakTVar' +-- | Lifted version of 'STM.mkWeakTVar'. mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a)) -mkWeakTVar var final = unsafeUnliftIO $ \unlift -> do - STM.mkWeakTVar var $ unlift final +mkWeakTVar var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + STM.mkWeakTVar var . unEff f =<< cloneEnv es --- | Lifted version of 'STM.newTMVarIO' +-- | Lifted version of 'STM.newTMVarIO'. newTMVarIO :: Concurrent :> es => a -> Eff es (TMVar a) newTMVarIO = unsafeEff_ . STM.newTMVarIO --- | Lifted version of 'STM.newEmptyTMVarIO' +-- | Lifted version of 'STM.newEmptyTMVarIO'. newEmptyTMVarIO :: Concurrent :> es => Eff es (TMVar a) newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO --- | Lifted version of 'STM.mkWeakTMVar' +-- | Lifted version of 'STM.mkWeakTMVar'. mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a)) -mkWeakTMVar var final = unsafeUnliftIO $ \unlift -> do - STM.mkWeakTMVar var $ unlift final +mkWeakTMVar var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + STM.mkWeakTMVar var . unEff f =<< cloneEnv es --- | Lifted version of 'STM.newTChanIO' +-- | Lifted version of 'STM.newTChanIO'. newTChanIO :: Concurrent :> es => Eff es (TChan a) newTChanIO = unsafeEff_ STM.newTChanIO --- | Lifted version of 'STM.newBroadcastTChanIO' +-- | Lifted version of 'STM.newBroadcastTChanIO'. newBroadcastTChanIO :: Concurrent :> es => Eff es (TChan a) newBroadcastTChanIO = unsafeEff_ STM.newBroadcastTChanIO --- | Lifted version of 'STM.newTQueueIO' +-- | Lifted version of 'STM.newTQueueIO'. newTQueueIO :: Concurrent :> es => Eff es (TQueue a) newTQueueIO = unsafeEff_ STM.newTQueueIO --- | Lifted version of 'STM.newTBQueueIO' +-- | Lifted version of 'STM.newTBQueueIO'. newTBQueueIO :: Concurrent :> es => Natural -> Eff es (TBQueue a) newTBQueueIO = unsafeEff_ . STM.newTBQueueIO diff --git a/effectful/src/Effectful/FileSystem.hs b/effectful/src/Effectful/FileSystem.hs index 8b36638..887d653 100644 --- a/effectful/src/Effectful/FileSystem.hs +++ b/effectful/src/Effectful/FileSystem.hs @@ -272,7 +272,7 @@ findFileWith -> [FilePath] -> String -> Eff es (Maybe FilePath) -findFileWith p dirs n = unsafeUnliftIO $ \unlift -> do +findFileWith p dirs n = unsafeSeqUnliftIO $ \unlift -> do D.findFileWith (unlift . p) dirs n -- | Lifted 'D.findFilesWith'. @@ -282,7 +282,7 @@ findFilesWith -> [FilePath] -> String -> Eff es [FilePath] -findFilesWith p dirs ns = unsafeUnliftIO $ \unlift -> do +findFilesWith p dirs ns = unsafeSeqUnliftIO $ \unlift -> do D.findFilesWith (unlift . p) dirs ns ---------------------------------------- diff --git a/effectful/src/Effectful/FileSystem/IO.hs b/effectful/src/Effectful/FileSystem/IO.hs index e6c9b8a..f8a6f79 100644 --- a/effectful/src/Effectful/FileSystem/IO.hs +++ b/effectful/src/Effectful/FileSystem/IO.hs @@ -52,7 +52,7 @@ withFile -> IOMode -> (Handle -> Eff es a) -> Eff es a -withFile fp mode inner = unsafeUnliftIO $ \unlift -> do +withFile fp mode inner = unsafeSeqUnliftIO $ \unlift -> do IO.withFile fp mode $ unlift . inner -- | Lifted version of 'IO.withBinaryFile'. @@ -62,7 +62,7 @@ withBinaryFile -> IOMode -> (Handle -> Eff es a) -> Eff es a -withBinaryFile fp mode inner = unsafeUnliftIO $ \unlift -> do +withBinaryFile fp mode inner = unsafeSeqUnliftIO $ \unlift -> do IO.withBinaryFile fp mode $ unlift . inner -- | Lifted version of 'IO.openFile' diff --git a/effectful/src/Effectful/Process.hs b/effectful/src/Effectful/Process.hs index 697912c..8cbe05a 100644 --- a/effectful/src/Effectful/Process.hs +++ b/effectful/src/Effectful/Process.hs @@ -133,7 +133,7 @@ withCreateProcess => P.CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> P.ProcessHandle -> Eff es a) -> Eff es a -withCreateProcess cp cb = unsafeUnliftIO $ \unlift -> do +withCreateProcess cp cb = unsafeSeqUnliftIO $ \unlift -> do P.withCreateProcess cp $ \inh outh errh ph -> unlift $ cb inh outh errh ph -- | Lifted 'P.cleanupProcess'. diff --git a/effectful/src/Effectful/Resource.hs b/effectful/src/Effectful/Resource.hs index 722c6ca..8472e6f 100644 --- a/effectful/src/Effectful/Resource.hs +++ b/effectful/src/Effectful/Resource.hs @@ -29,6 +29,7 @@ import qualified Control.Monad.Trans.Resource.Internal as RI import Effectful import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive -- | Data tag for a resource effect. data Resource :: Effect diff --git a/effectful/src/Effectful/Temporary.hs b/effectful/src/Effectful/Temporary.hs index 2d987f8..9438c53 100644 --- a/effectful/src/Effectful/Temporary.hs +++ b/effectful/src/Effectful/Temporary.hs @@ -36,7 +36,7 @@ withSystemTempFile -> (FilePath -> Handle -> Eff es a) -- ^ Callback that can use the file. -> Eff es a -withSystemTempFile template action = unsafeUnliftIO $ \unlift -> do +withSystemTempFile template action = unsafeSeqUnliftIO $ \unlift -> do T.withSystemTempFile template $ \fp handle -> unlift $ action fp handle -- | Lifted 'T.withSystemTempDirectory'. @@ -47,7 +47,7 @@ withSystemTempDirectory -> (FilePath -> Eff es a) -- ^ Callback that can use the directory. -> Eff es a -withSystemTempDirectory template action = unsafeUnliftIO $ \unlift -> do +withSystemTempDirectory template action = unsafeSeqUnliftIO $ \unlift -> do T.withSystemTempDirectory template $ \fp -> unlift $ action fp -- | Lifted 'T.withTempFile'. @@ -60,7 +60,7 @@ withTempFile -> (FilePath -> Handle -> Eff es a) -- ^ Callback that can use the file. -> Eff es a -withTempFile tmpDir template action = unsafeUnliftIO $ \unlift -> do +withTempFile tmpDir template action = unsafeSeqUnliftIO $ \unlift -> do T.withTempFile tmpDir template $ \fp handle -> unlift $ action fp handle -- | Lifted 'T.withTempDirectory'. @@ -73,5 +73,5 @@ withTempDirectory -> (FilePath -> Eff es a) -- ^ Callback that can use the directory. -> Eff es a -withTempDirectory tmpDir template action = unsafeUnliftIO $ \unlift -> do +withTempDirectory tmpDir template action = unsafeSeqUnliftIO $ \unlift -> do T.withTempDirectory tmpDir template $ \fp -> unlift $ action fp