@@ -33,6 +33,7 @@ module Effectful.Internal.Monad
3333 , Limit(..)
3434 , unliftStrategy
3535 , withUnliftStrategy
36+ , withEffToIO
3637
3738 --- *** Low-level helpers
3839 , unsafeWithLiftMapIO
@@ -58,18 +59,18 @@ module Effectful.Internal.Monad
5859import Control.Applicative (liftA2)
5960import Control.Concurrent (myThreadId)
6061import Control.Exception
62+import Control.Monad.Base
6163import Control.Monad.Fix
6264import Control.Monad.IO.Class
65+import Control.Monad.IO.Unlift
6366import Control.Monad.Primitive
67+import Control.Monad.Trans.Control
6468import Data.Unique
6569import GHC.Exts (oneShot)
6670import GHC.IO (IO(..))
6771import GHC.Stack (HasCallStack)
6872import System.IO.Unsafe (unsafeDupablePerformIO)
69−import qualified Control.Monad.Base as M
7073import qualified Control.Monad.Catch as E
71−import qualified Control.Monad.IO.Unlift as M
72−import qualified Control.Monad.Trans.Control as M
7374
7475import Effectful.Internal.Effect
7576import Effectful.Internal.Env
@@ -290,40 +291,21 @@ runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
290291instance IOE :> es => MonadIO (Eff es) where
291292 liftIO = unsafeEff_
292293
293−instance IOE :> es => M.MonadUnliftIO (Eff es) where
294− withRunInIO = withRunInIO
295− where
296− -- A trick to show name of the function in the call stack.
297− withRunInIO
298− :: (HasCallStack, IOE :> es)
299− => ((forall r. Eff es r -> IO r) -> IO a)
300− -> Eff es a
301− withRunInIO f = unliftStrategy >>= \case
302− SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
303− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
304− unsafeEff $ \es -> unsafeConcUnliftEff es p b f
294+-- | Use 'withEffToIO' if you want accurate stack traces on errors.
295+instance IOE :> es => MonadUnliftIO (Eff es) where
296+ withRunInIO = withEffToIO
305297
306298-- | Instance included for compatibility with existing code, usage of 'liftIO'
307299-- is preferrable.
308−instance IOE :> es => M.MonadBase IO (Eff es) where
300+instance IOE :> es => MonadBase IO (Eff es) where
309301 liftBase = unsafeEff_
310302
311303-- | Instance included for compatibility with existing code, usage of
312304-- 'withRunInIO' is preferrable.
313−instance IOE :> es => M.MonadBaseControl IO (Eff es) where
305+instance IOE :> es => MonadBaseControl IO (Eff es) where
314306 type StM (Eff es) a = a
307+ liftBaseWith = withEffToIO
315308 restoreM = pure
316− liftBaseWith = liftBaseWith
317− where
318− -- A trick to show name of the function in the call stack.
319− liftBaseWith
320− :: (HasCallStack, IOE :> es)
321− => ((forall r. Eff es r -> IO r) -> IO a)
322− -> Eff es a
323− liftBaseWith f = unliftStrategy >>= \case
324− SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
325− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
326− unsafeEff $ \es -> unsafeConcUnliftEff es p b f
327309
328310----------------------------------------
329311-- Primitive
@@ -401,10 +383,25 @@ unliftStrategy = readerEffectM $ \(IdE (IOE unlift)) -> pure unlift
401383
402384-- | Locally override the 'UnliftStrategy' with a given value.
403385--
404−-- /Note:/ the strategy is always reset to 'SeqUnlift' for new threads.
386+-- /Note:/ the strategy is reset to 'SeqUnlift' for new threads.
405387withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
406388withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
407389
390+-- | Create an unlifting function with the current 'UnliftStrategy'.
391+--
392+-- This function is equivalent to 'withRunInIO', but has a 'HasCallStack'
393+-- constraint for accurate stack traces in case an insufficiently powerful
394+-- 'UnliftStrategy' is used and the unlifting function fails.
395+withEffToIO
396+ :: (HasCallStack, IOE :> es)
397+ => ((forall r. Eff es r -> IO r) -> IO a)
398+ -- ^ Continuation with the unlifting function in scope.
399+ -> Eff es a
400+withEffToIO f = unliftStrategy >>= \case
401+ SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
402+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
403+ unsafeEff $ \es -> unsafeConcUnliftEff es p b f
404+
408405----------------------------------------
409406-- Helpers
410407