diff --git a/effectful-core/src/Effectful/Dispatch/Dynamic.hs b/effectful-core/src/Effectful/Dispatch/Dynamic.hs index 7caa3a6..5cb51ba 100644 --- a/effectful-core/src/Effectful/Dispatch/Dynamic.hs +++ b/effectful-core/src/Effectful/Dispatch/Dynamic.hs @@ -77,7 +77,7 @@ localSeqUnlift -- ^ Continuation with the unlifting function in scope. -> Eff es a localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do - seqUnliftEff les $ \unlift -> do + seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the @@ -89,7 +89,7 @@ localSeqUnliftIO -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftEff les k +localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k -- | Create a local unlifting function with the given strategy. localUnlift @@ -102,10 +102,10 @@ localUnlift -> Eff es a localUnlift (LocalEnv les) strategy k = case strategy of SeqUnlift -> unsafeEff $ \es -> do - seqUnliftEff les $ \unlift -> do + seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftEff les p l $ \unlift -> do + concUnliftIO les p l $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift -- | Create a local unlifting function with the given strategy. @@ -118,8 +118,8 @@ localUnliftIO -- ^ Continuation with the unlifting function in scope. -> Eff es a localUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftEff les k - ConcUnlift p l -> liftIO $ concUnliftEff les p l k + SeqUnlift -> liftIO $ seqUnliftIO les k + ConcUnlift p l -> liftIO $ concUnliftIO les p l k -- | Utility for lifting 'Eff' operations of type -- @@ -142,7 +142,7 @@ withLiftMap !_ k = unsafeEff $ \es -> do -- The LocalEnv parameter is not used, but we need it to constraint the -- localEs type variable. It's also strict so that callers don't cheat. (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do - seqUnliftEff localEs $ \unlift -> do + seqUnliftIO localEs $ \unlift -> do (`unEff` es) . mapEff . unsafeEff_ $ unlift m -- | Utility for lifting 'IO' operations of type @@ -180,7 +180,7 @@ withLiftMapIO withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do -- The LocalEnv parameter is not used, but we need it to constraint the -- localEs type variable. It's also strict so that callers don't cheat. - seqUnliftEff es $ \unlift -> mapIO $ unlift m + seqUnliftIO es $ \unlift -> mapIO $ unlift m ---------------------------------------- -- Bidirectional lifts @@ -202,12 +202,12 @@ localLiftUnlift -> Eff es a localLiftUnlift (LocalEnv les) strategy k = case strategy of SeqUnlift -> unsafeEff $ \es -> do - seqUnliftEff es $ \unliftEs -> do - seqUnliftEff les $ \unliftLocalEs -> do + seqUnliftIO es $ \unliftEs -> do + seqUnliftIO les $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftEff es p l $ \unliftEs -> do - concUnliftEff les p l $ \unliftLocalEs -> do + concUnliftIO es p l $ \unliftEs -> do + concUnliftIO les p l $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) -- | Create a local unlifting function with the given strategy along with an @@ -227,8 +227,8 @@ localLiftUnliftIO -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a localLiftUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftEff les $ k unsafeEff_ - ConcUnlift p l -> liftIO $ concUnliftEff les p l $ k unsafeEff_ + SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_ + ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_ -- $setup -- >>> import Control.Concurrent diff --git a/effectful-core/src/Effectful/Dispatch/Static.hs b/effectful-core/src/Effectful/Dispatch/Static.hs index 1a5b7cd..f4e3abe 100644 --- a/effectful-core/src/Effectful/Dispatch/Static.hs +++ b/effectful-core/src/Effectful/Dispatch/Static.hs @@ -46,6 +46,41 @@ module Effectful.Dispatch.Static , unEff ) where +import GHC.Stack (HasCallStack) + import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Monad + +-- | Utility for lifting 'IO' operations of type +-- +-- @'IO' a -> 'IO' b@ +-- +-- to +-- +-- @'Eff' es a -> 'Eff' es b@ +-- +-- This function is __unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- operations. +-- +-- - The 'IO' operation 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) + +-- | Utility for running 'Eff' computations locally in the 'IO' monad. +-- +-- This function is __unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- operations. +-- +-- - Unlifted 'Eff' operations must not be run in a thread distinct from the +-- caller of 'unsafeUnliftIO', but it's not checked anywhere. +unsafeUnliftIO + :: HasCallStack + => ((forall r. Eff es r -> IO r) -> IO a) + -> Eff es a +unsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es) diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index 98b8521..f5beb63 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -36,10 +36,8 @@ module Effectful.Internal.Monad , UnliftError(..) --- *** Low-level helpers - , unsafeLiftMapIO - , unsafeUnliftIO - , seqUnliftEff - , concUnliftEff + , seqUnliftIO + , concUnliftIO -- * Effects @@ -148,41 +146,8 @@ unsafeEff m = Eff (oneShot m) unsafeEff_ :: IO a -> Eff es a unsafeEff_ m = unsafeEff $ \_ -> m --- | Utility for lifting 'IO' operations of type --- --- @'IO' a -> 'IO' b@ --- --- to --- --- @'Eff' es a -> 'Eff' es b@ --- --- This function is __unsafe__ because: --- --- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' --- operations. --- --- - The 'IO' operation 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) - --- | Utility for running 'Eff' computations locally in the 'IO' monad. --- --- This function is __unsafe__ because: --- --- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' --- operations. --- --- - Unlifted 'Eff' operations must not be run in a thread distinct from the --- caller of 'unsafeUnliftIO', but it's not checked anywhere. -unsafeUnliftIO - :: HasCallStack - => ((forall r. Eff es r -> IO r) -> IO a) - -> Eff es a -unsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es) - ---------------------------------------- --- Unlifting Eff +-- Unlifting IO -- | Get the current 'UnliftStrategy'. unliftStrategy :: IOE :> es => Eff es UnliftStrategy @@ -194,28 +159,6 @@ unliftStrategy = do withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift) --- | Lower 'Eff' operations into 'IO' ('SeqUnlift'). --- --- Exceptions thrown by this function: --- --- - 'InvalidUseOfSeqUnlift' if the unlift function is used in another thread. -seqUnliftEff - :: HasCallStack - => Env es - -> ((forall r. Eff es r -> IO r) -> IO a) - -> IO a -seqUnliftEff es k = seqUnliftIO k es unEff - --- | Lower 'Eff' operations into 'IO' ('ConcUnlift'). -concUnliftEff - :: HasCallStack - => Env es - -> Persistence - -> Limit - -> ((forall r. Eff es r -> IO r) -> IO a) - -> IO a -concUnliftEff es persistence limit k = concUnliftIO persistence limit k es unEff - -- | Create an unlifting function with the current 'UnliftStrategy'. -- -- This function is equivalent to 'withRunInIO', but has a 'HasCallStack' @@ -229,9 +172,31 @@ withEffToIO -- ^ Continuation with the unlifting function in scope. -> Eff es a withEffToIO f = unliftStrategy >>= \case - SeqUnlift -> unsafeEff $ \es -> seqUnliftEff es f + SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do - unsafeEff $ \es -> concUnliftEff es p b f + unsafeEff $ \es -> concUnliftIO es p b f + +-- | Lower 'Eff' operations into 'IO' ('SeqUnlift'). +-- +-- Exceptions thrown by this function: +-- +-- - 'InvalidUseOfSeqUnlift' if the unlift function is used in another thread. +seqUnliftIO + :: HasCallStack + => Env es + -> ((forall r. Eff es r -> IO r) -> IO a) + -> IO a +seqUnliftIO es k = seqUnlift k es unEff + +-- | Lower 'Eff' operations into 'IO' ('ConcUnlift'). +concUnliftIO + :: HasCallStack + => Env es + -> Persistence + -> Limit + -> ((forall r. Eff es r -> IO r) -> IO a) + -> IO a +concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff ---------------------------------------- -- Base diff --git a/effectful-core/src/Effectful/Internal/Unlift.hs b/effectful-core/src/Effectful/Internal/Unlift.hs index a5c6731..6a4d6e1 100644 --- a/effectful-core/src/Effectful/Internal/Unlift.hs +++ b/effectful-core/src/Effectful/Internal/Unlift.hs @@ -13,10 +13,10 @@ module Effectful.Internal.Unlift , Limit(..) -- * Unlifting functions - , seqUnliftIO - , concUnliftIO - , ephemeralConcUnliftIO - , persistentConcUnliftIO + , seqUnlift + , concUnlift + , ephemeralConcUnlift + , persistentConcUnlift -- * Unlifting errors , UnliftError(..) @@ -100,13 +100,13 @@ data Limit -- Exceptions thrown by this function: -- -- - 'InvalidUseOfSeqUnlift' if the unlift function is used in another thread. -seqUnliftIO +seqUnlift :: HasCallStack => ((forall r. m r -> IO r) -> IO a) -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a -seqUnliftIO k es unEff = do +seqUnlift k es unEff = do tid0 <- myThreadId k $ \m -> do tid <- myThreadId @@ -115,7 +115,7 @@ seqUnliftIO k es unEff = do else throwIO InvalidUseOfSeqUnlift -- | Concurrent unlift for various strategies and limits. -concUnliftIO +concUnlift :: HasCallStack => Persistence -> Limit @@ -123,14 +123,14 @@ concUnliftIO -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a -concUnliftIO Ephemeral (Limited uses) k = - ephemeralConcUnliftIO uses k -concUnliftIO Ephemeral Unlimited k = - ephemeralConcUnliftIO maxBound k -concUnliftIO Persistent (Limited threads) k = - persistentConcUnliftIO False threads k -concUnliftIO Persistent Unlimited k = - persistentConcUnliftIO True maxBound k +concUnlift Ephemeral (Limited uses) k = + ephemeralConcUnlift uses k +concUnlift Ephemeral Unlimited k = + ephemeralConcUnlift maxBound k +concUnlift Persistent (Limited threads) k = + persistentConcUnlift False threads k +concUnlift Persistent Unlimited k = + persistentConcUnlift True maxBound k -- | Concurrent unlift that doesn't preserve the environment between calls to -- the unlifting function in threads other than its creator. @@ -139,7 +139,7 @@ concUnliftIO Persistent Unlimited k = -- -- - 'InvalidNumberOfUses' if the number of uses is less or equal zero. -- - 'ExceededNumberOfUses' if the unlift function is called too often. -ephemeralConcUnliftIO +ephemeralConcUnlift :: HasCallStack => Int -- ^ Number of permitted uses of the unlift function. @@ -147,7 +147,7 @@ ephemeralConcUnliftIO -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a -ephemeralConcUnliftIO uses k es0 unEff = do +ephemeralConcUnlift uses k es0 unEff = do unless (uses > 0) $ do throwIO $ InvalidNumberOfUses uses tid0 <- myThreadId @@ -176,7 +176,7 @@ ephemeralConcUnliftIO uses k es0 unEff = do -- - 'InvalidNumberOfThreads' if the number of threads is less or equal zero. -- - 'ExceededNumberOfThreads' if the unlift function is called by too many -- threads. -persistentConcUnliftIO +persistentConcUnlift :: HasCallStack => Bool -> Int @@ -185,7 +185,7 @@ persistentConcUnliftIO -> Env es -> (forall r. m r -> Env es -> IO r) -> IO a -persistentConcUnliftIO cleanUp threads k es0 unEff = do +persistentConcUnlift cleanUp threads k es0 unEff = do unless (threads > 0) $ do throwIO $ InvalidNumberOfThreads threads tid0 <- myThreadId