From c4014f49c6d84d37631f4da86d6281bc8552d640 Mon Sep 17 00:00:00 2001 From: Joshua Potter Date: Thu, 31 Mar 2022 23:48:48 -0400 Subject: [PATCH] Add `UnliftIO` support, passing through stylish-haskell. --- fused-effects-exceptions.cabal | 6 +- src/Control/Effect/Exception.hs | 135 ++++----- src/Control/Effect/Exception/Internal.hs | 132 +++++++++ src/Control/Effect/Exception/UnliftIO.hs | 345 +++++++++++++++++++++++ test/Main.hs | 13 +- 5 files changed, 551 insertions(+), 80 deletions(-) create mode 100644 src/Control/Effect/Exception/Internal.hs create mode 100644 src/Control/Effect/Exception/UnliftIO.hs diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index c48b598..977de9c 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: fused-effects-exceptions -version: 1.1.0.1 +version: 1.1.0.2 synopsis: Handle exceptions thrown in IO with fused-effects. description: Provides Resource and Catch effects capable of reacting to and catching GHC's dynamic exceptions. homepage: https://github.com/fused-effects/fused-effects-exceptions#readme @@ -33,10 +33,14 @@ library exposed-modules: Control.Carrier.State.IORef Control.Effect.Exception + Control.Effect.Exception.UnliftIO + other-modules: + Control.Effect.Exception.Internal build-depends: base >= 4.7 && < 5 , fused-effects >= 1.1 , transformers >= 0.4 && < 0.6 + , unliftio-core >= 0.2 && < 0.3 test-suite test import: common diff --git a/src/Control/Effect/Exception.hs b/src/Control/Effect/Exception.hs index 947a5b9..121bea3 100644 --- a/src/Control/Effect/Exception.hs +++ b/src/Control/Effect/Exception.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, RankNTypes, StandaloneDeriving #-} --- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +-- | Operations from "Control.Exception" and "UnliftIO.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. -- -- @since 1.0.0.0 module Control.Effect.Exception @@ -9,7 +13,7 @@ module Control.Effect.Exception , throwTo , catch , catches -, Handler(..) +, U.Handler(..) , catchJust , handle , handleJust @@ -39,77 +43,69 @@ module Control.Effect.Exception , run ) where -import Control.Concurrent (ThreadId) -import Control.Effect.Lift -import Control.Exception hiding - ( throwIO - , ioError - , throwTo - , catch - , catches - , Handler - , catchJust - , handle - , handleJust - , try - , tryJust - , evaluate - , mask - , mask_ - , uninterruptibleMask - , uninterruptibleMask_ - , getMaskingState - , interruptible +import Control.Concurrent (ThreadId) +import qualified Control.Effect.Exception.UnliftIO as U +import Control.Effect.Lift +import Control.Exception hiding + ( Handler , allowInterrupt , bracket - , bracket_ , bracketOnError + , bracket_ + , catch + , catchJust + , catches + , evaluate , finally + , getMaskingState + , handle + , handleJust + , interruptible + , ioError + , mask + , mask_ , onException + , throwIO + , throwTo + , try + , tryJust + , uninterruptibleMask + , uninterruptibleMask_ ) import qualified Control.Exception as Exc -import Prelude hiding (ioError) +import Prelude hiding (ioError) --- | See @"Control.Exception".'Exc.throwIO'@. +-- | See @"Unlift.Exception".throwIO@. -- -- @since 1.0.0.0 throwIO :: (Exc.Exception e, Has (Lift IO) sig m) => e -> m a -throwIO = sendM . Exc.throwIO +throwIO = U.throwIO @IO -- | See @"Control.Exception".'Exc.ioError'@. -- -- @since 1.0.0.0 ioError :: Has (Lift IO) sig m => IOError -> m a -ioError = sendM . Exc.ioError +ioError = U.ioError @IO -- | See @"Control.Exception".'Exc.throwTo'@. -- -- @since 1.0.0.0 throwTo :: (Exc.Exception e, Has (Lift IO) sig m) => ThreadId -> e -> m () -throwTo thread = sendM . Exc.throwTo thread +throwTo = U.throwTo @IO --- | See @"Control.Exception".'Exc.catch'@. +-- | See @"UnliftIO.Exception".catch@. -- -- @since 1.0.0.0 catch :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a -catch m h = liftWith $ \ run ctx -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h) +catch = U.catch @IO --- | See @"Control.Exception".'Exc.catches'@. +-- | See @"UnliftIO.Exception".catches@. -- -- @since 1.0.0.0 -catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a -catches m hs = liftWith $ \ run ctx -> - Exc.catches (run (m <$ ctx)) (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs) +catches :: Has (Lift IO) sig m => m a -> [U.Handler m a] -> m a +catches = U.catches @IO --- | See @"Control.Exception".'Exc.Handler'@. --- --- @since 1.0.0.0 -data Handler m a - = forall e . Exc.Exception e => Handler (e -> m a) - -deriving instance Functor m => Functor (Handler m) - --- | See @"Control.Exception".'Exc.catchJust'@. +-- | See @"UnliftIO.Exception".catchJust@. -- -- @since 1.0.0.0 catchJust @@ -118,13 +114,13 @@ catchJust -> m a -> (b -> m a) -> m a -catchJust p m h = liftWith $ \ run ctx -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h) +catchJust = U.catchJust @IO -- | See @"Control.Exception".'Exc.handle'@. -- -- @since 1.0.0.0 handle :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a -handle = flip catch +handle = U.handle @IO -- | See @"Control.Exception".'Exc.handleJust'@. -- @@ -135,69 +131,67 @@ handleJust -> (b -> m a) -> m a -> m a -handleJust p = flip (catchJust p) +handleJust = U.handleJust @IO -- | See @"Control.Exception".'Exc.try'@. -- -- @since 1.0.0.0 try :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> m (Either e a) -try m = (Right <$> m) `catch` (pure . Left) +try = U.try @IO -- | See @"Control.Exception".'Exc.tryJust'@. -- -- @since 1.0.0.0 tryJust :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> Maybe b) -> m a -> m (Either b a) -tryJust p m = catchJust p (Right <$> m) (pure . Left) +tryJust = U.tryJust @IO --- | See @"Control.Exception".'Exc.evaluate'@. +-- | See @"UnliftIO.Exception".evaluate@. -- -- @since 1.0.0.0 evaluate :: Has (Lift IO) sig m => a -> m a -evaluate = sendM . Exc.evaluate +evaluate = U.evaluate @IO --- | See @"Control.Exception".'Exc.mask'@. +-- | See @"UnliftIO.Exception".mask@. -- -- @since 1.0.0.0 mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b -mask with = liftWith $ \ run ctx -> Exc.mask $ \ restore -> - run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx) +mask = U.mask @IO -- | See @"Control.Exception".'Exc.mask_'@. -- -- @since 1.0.0.0 mask_ :: Has (Lift IO) sig m => m a -> m a -mask_ m = mask (\_ -> m) +mask_ = U.mask_ @IO --- | See @"Control.Exception".'Exc.uninterruptibleMask'@. +-- | See @"UnliftIO.Exception".uninterruptibleMask@. -- -- @since 1.0.0.0 uninterruptibleMask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b -uninterruptibleMask with = liftWith $ \ run ctx -> Exc.uninterruptibleMask $ \ restore -> - run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx) +uninterruptibleMask = U.uninterruptibleMask @IO -- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. -- -- @since 1.0.0.0 uninterruptibleMask_ :: Has (Lift IO) sig m => m a -> m a -uninterruptibleMask_ m = uninterruptibleMask (\_ -> m) +uninterruptibleMask_ = U.uninterruptibleMask_ @IO -- | See @"Control.Exception".'Exc.getMaskingState'@. -- -- @since 1.0.0.0 getMaskingState :: Has (Lift IO) sig m => m Exc.MaskingState -getMaskingState = sendM Exc.getMaskingState +getMaskingState = U.getMaskingState @IO -- | See @"Control.Exception".'Exc.interruptible'@. -- -- @since 1.0.0.0 interruptible :: Has (Lift IO) sig m => m a -> m a -interruptible m = liftWith $ \ run ctx -> Exc.interruptible (run (m <$ ctx)) +interruptible = U.interruptible @IO -- | See @"Control.Exception".'Exc.allowInterrupt'@. -- -- @since 1.0.0.0 allowInterrupt :: Has (Lift IO) sig m => m () -allowInterrupt = sendM Exc.allowInterrupt +allowInterrupt = U.allowInterrupt @IO -- | See @"Control.Exception".'Exc.bracket'@. -- @@ -208,10 +202,7 @@ bracket -> (a -> m b) -> (a -> m c) -> m c -bracket acquire release m = mask $ \ restore -> do - a <- acquire - r <- restore (m a) `onException` release a - r <$ release a +bracket = U.bracket @IO -- | See @"Control.Exception".'Exc.bracket_'@. -- @@ -222,7 +213,7 @@ bracket_ -> m b -> m c -> m c -bracket_ before after thing = bracket before (const after) (const thing) +bracket_ = U.bracket_ @IO -- | See @"Control.Exception".'Exc.bracketOnError'@. -- @@ -233,9 +224,7 @@ bracketOnError -> (a -> m b) -> (a -> m c) -> m c -bracketOnError acquire release m = mask $ \ restore -> do - a <- acquire - restore (m a) `onException` release a +bracketOnError = U.bracketOnError @IO -- | See @"Control.Exception".'Exc.finally'@. -- @@ -245,10 +234,10 @@ finally => m a -> m b -> m a -finally m sequel = mask $ \ restore -> (restore m `onException` sequel) <* sequel +finally = U.finally @IO -- | See @"Control.Exception".'Exc.onException'@. -- -- @since 1.0.0.0 onException :: Has (Lift IO) sig m => m a -> m b -> m a -onException io what = io `catch` \e -> what >> throwIO (e :: Exc.SomeException) +onException = U.onException @IO diff --git a/src/Control/Effect/Exception/Internal.hs b/src/Control/Effect/Exception/Internal.hs new file mode 100644 index 0000000..4934e94 --- /dev/null +++ b/src/Control/Effect/Exception/Internal.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + +-- | Operations from "UnliftIO.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +-- +-- These methods are shamelessly copied from the @unliftio@ module in an effort to keep dependencies small. +-- @unliftio-core@ is assumed fair game though considering it's included in core @fused-effects@ package. +-- +-- @since +module Control.Effect.Exception.Internal +( -- * Throwing + throwIO + -- * Catching (with recovery) +, catch +, catchJust +, Handler (..) +, catches + -- * Evaluation +, evaluate + -- * Masking +, mask +, uninterruptibleMask + -- * Reexports +, Exception (..) +, Typeable +, SomeException (..) +, SomeAsyncException (..) +, IOException +) where + +import Control.Exception (Exception(..), IOException, SomeAsyncException(..), SomeException(..)) +import qualified Control.Exception as EUnsafe +import Control.Monad.IO.Unlift +import Data.Typeable (Typeable, cast) + +-- | Catch a synchronous (but not asynchronous) exception and recover from it. +-- +-- This is parameterized on the exception type. To catch all synchronous exceptions, +-- use 'catchAny'. +catch + :: (MonadUnliftIO m, Exception e) + => m a -- ^ action + -> (e -> m a) -- ^ handler + -> m a +catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> + if isSyncException e + then run (g e) + -- intentionally rethrowing an async exception synchronously, + -- since we want to preserve async behavior + else EUnsafe.throwIO e + +-- | 'catchJust' is like 'catch' but it takes an extra argument which +-- is an exception predicate, a function which selects which type of +-- exceptions we're interested in. +catchJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a +catchJust f a b = a `catch` \e -> maybe (liftIO (throwIO e)) b $ f e + +-- | A helper data type for usage with 'catches' and similar functions. +data Handler m a = forall e . Exception e => Handler (e -> m a) + +-- | Internal. +catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a +catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers + where tryHandler (Handler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res + +-- | Similar to 'catch', but provides multiple different handler functions. +-- +-- For more information on motivation, see @base@'s 'EUnsafe.catches'. Note that, +-- unlike that function, this function will not catch asynchronous exceptions. +catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a +catches io handlers = io `catch` catchesHandler handlers + +-- | Lifted version of 'EUnsafe.evaluate'. +evaluate :: MonadIO m => a -> m a +evaluate = liftIO . EUnsafe.evaluate + +-- | Synchronously throw the given exception. +-- +-- Note that, if you provide an exception value which is of an asynchronous +-- type, it will be wrapped up in 'SyncExceptionWrapper'. See 'toSyncException'. +throwIO :: (MonadIO m, Exception e) => e -> m a +throwIO = liftIO . EUnsafe.throwIO . toSyncException + +-- | Wrap up an asynchronous exception to be treated as a synchronous +-- exception. +-- +-- This is intended to be created via 'toSyncException'. +data SyncExceptionWrapper = forall e. Exception e => SyncExceptionWrapper e + deriving Typeable + +instance Show SyncExceptionWrapper where + show (SyncExceptionWrapper e) = show e + +instance Exception SyncExceptionWrapper where +#if MIN_VERSION_base(4,8,0) + displayException (SyncExceptionWrapper e) = displayException e +#endif + +-- | Convert an exception into a synchronous exception. +-- +-- For synchronous exceptions, this is the same as 'toException'. +-- For asynchronous exceptions, this will wrap up the exception with +-- 'SyncExceptionWrapper'. +toSyncException :: Exception e => e -> SomeException +toSyncException e = + case fromException se of + Just (SomeAsyncException _) -> toException (SyncExceptionWrapper e) + Nothing -> se + where + se = toException e + +-- | Check if the given exception is synchronous. +isSyncException :: Exception e => e -> Bool +isSyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> False + Nothing -> True + +-- | Unlifted version of 'EUnsafe.mask'. +mask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b +mask f = withRunInIO $ \run -> EUnsafe.mask $ \unmask -> + run $ f $ liftIO . unmask . run + +-- | Unlifted version of 'EUnsafe.uninterruptibleMask'. +uninterruptibleMask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b +uninterruptibleMask f = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \unmask -> + run $ f $ liftIO . unmask . run diff --git a/src/Control/Effect/Exception/UnliftIO.hs b/src/Control/Effect/Exception/UnliftIO.hs new file mode 100644 index 0000000..cd121b5 --- /dev/null +++ b/src/Control/Effect/Exception/UnliftIO.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +-- | Operations from "Control.Exception" and "UnliftIO.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +-- +-- @since 1.1.0.2 +module Control.Effect.Exception.UnliftIO +( -- * Lifted "Control.Exception" operations + throwIO +, ioError +, throwTo +, catch +, catches +, Handler(..) +, catchJust +, handle +, handleJust +, try +, tryJust +, evaluate +, mask +, mask_ +, uninterruptibleMask +, uninterruptibleMask_ +, getMaskingState +, interruptible +, allowInterrupt +, bracket +, bracket_ +, bracketOnError +, finally +, onException +, module Control.Exception + -- * Lift effect +, Lift(..) +, sendM +, liftWith + -- * Re-exports +, Algebra +, Has +, run +) where + +import Control.Concurrent (ThreadId) +import qualified Control.Effect.Exception.Internal as Exc +import Control.Effect.Lift +import Control.Exception hiding + ( Handler + , allowInterrupt + , bracket + , bracketOnError + , bracket_ + , catch + , catchJust + , catches + , evaluate + , finally + , getMaskingState + , handle + , handleJust + , interruptible + , ioError + , mask + , mask_ + , onException + , throwIO + , throwTo + , try + , tryJust + , uninterruptibleMask + , uninterruptibleMask_ + ) +import qualified Control.Exception as EUnsafe +import Control.Monad.IO.Unlift (MonadIO, MonadUnliftIO, liftIO, withRunInIO) +import Prelude hiding (ioError) + +-- | See @"Unlift.Exception".throwIO@. +-- +-- @since 1.1.0.2 +throwIO + :: forall n e sig m a + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => e + -> m a +throwIO = sendM @n . Exc.throwIO + +-- | See @"Control.Exception".'Exc.ioError'@. +-- +-- @since 1.1.0.2 +ioError + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => IOError + -> m a +ioError = sendM @n . liftIO . EUnsafe.ioError + +-- | See @"Control.Exception".'Exc.throwTo'@. +-- +-- @since 1.1.0.2 +throwTo + :: forall n e sig m a + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => ThreadId + -> e + -> m () +throwTo thread = sendM @n . liftIO . EUnsafe.throwTo thread + +-- | See @"UnliftIO.Exception".catch@. +-- +-- @since 1.1.0.2 +catch + :: forall n e sig m a + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => m a + -> (e -> m a) + -> m a +catch m h = liftWith @n $ + \run ctx -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h) + +-- | See @"UnliftIO.Exception".catches@. +-- +-- @since 1.1.0.2 +catches + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> [Handler m a] + -> m a +catches m hs = liftWith @n $ + \ run ctx -> Exc.catches + (run (m <$ ctx)) + (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs) + +-- | See @"Control.Exception".'Exc.Handler'@. +-- +-- @since +data Handler m a + = forall e . Exc.Exception e => Handler (e -> m a) + +deriving instance Functor m => Functor (Handler m) + +-- | See @"UnliftIO.Exception".catchJust@. +-- +-- @since 1.1.0.2 +catchJust + :: forall n e sig m a b + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => (e -> Maybe b) + -> m a + -> (b -> m a) + -> m a +catchJust p m h = liftWith @n $ + \ run ctx -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h) + +-- | See @"Control.Exception".'Exc.handle'@. +-- +-- @since 1.1.0.2 +handle + :: forall n e sig m a + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => (e -> m a) + -> m a + -> m a +handle = flip $ catch @n + +-- | See @"Control.Exception".'Exc.handleJust'@. +-- +-- @since 1.1.0.2 +handleJust + :: forall n e sig m a b + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => (e -> Maybe b) + -> (b -> m a) + -> m a + -> m a +handleJust p = flip (catchJust @n p) + +-- | See @"Control.Exception".'Exc.try'@. +-- +-- @since 1.1.0.2 +try + :: forall n e sig m a b + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => m a + -> m (Either e a) +try m = catch @n (Right <$> m) (pure . Left) + +-- | See @"Control.Exception".'Exc.tryJust'@. +-- +-- @since 1.1.0.2 +tryJust + :: forall n e sig m a b + . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) + => (e -> Maybe b) + -> m a + -> m (Either b a) +tryJust p m = catchJust @n p (Right <$> m) (pure . Left) + +-- | See @"UnliftIO.Exception".evaluate@. +-- +-- @since 1.1.0.2 +evaluate :: forall n sig m a. (MonadUnliftIO n, Has (Lift n) sig m) => a -> m a +evaluate = sendM @n . Exc.evaluate + +-- | See @"UnliftIO.Exception".mask@. +-- +-- @since 1.1.0.2 +mask + :: forall n sig m a b + . (MonadUnliftIO n, Has (Lift n) sig m) + => ((forall a . m a -> m a) -> m b) + -> m b +mask with = liftWith @n $ \ run ctx -> Exc.mask $ \ restore -> + run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx) + +-- | See @"Control.Exception".'Exc.mask_'@. +-- +-- @since 1.1.0.2 +mask_ + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m a +mask_ m = mask @n (const m) + +-- | See @"UnliftIO.Exception".uninterruptibleMask@. +-- +-- @since 1.1.0.2 +uninterruptibleMask + :: forall n sig m a b + . (MonadUnliftIO n, Has (Lift n) sig m) + => ((forall a . m a -> m a) -> m b) + -> m b +uninterruptibleMask with = liftWith @n $ + \ run ctx -> Exc.uninterruptibleMask $ \ restore -> + run (with (\ m -> liftWith $ + \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx) + +-- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. +-- +-- @since 1.1.0.2 +uninterruptibleMask_ + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m a +uninterruptibleMask_ m = uninterruptibleMask @n (const m) + +-- | See @"Control.Exception".'Exc.getMaskingState'@. +-- +-- @since 1.1.0.2 +getMaskingState + :: forall n sig m + . (MonadUnliftIO n, Has (Lift n) sig m) + => m EUnsafe.MaskingState +getMaskingState = sendM @n (liftIO EUnsafe.getMaskingState) + +-- | See @"Control.Exception".'Exc.interruptible'@. +-- +-- @since 1.1.0.2 +interruptible + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m a +interruptible m = liftWith @n $ \ run ctx -> withRunInIO $ \runInIO -> + EUnsafe.interruptible (runInIO $ run (m <$ ctx)) + +-- | See @"Control.Exception".'Exc.allowInterrupt'@. +-- +-- @since 1.1.0.2 +allowInterrupt + :: forall n sig m a + . (MonadUnliftIO n, Has (Lift n) sig m) + => m () +allowInterrupt = sendM @n (liftIO EUnsafe.allowInterrupt) + +-- | See @"Control.Exception".'Exc.bracket'@. +-- +-- @since 1.1.0.2 +bracket + :: forall n sig m a b c + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracket acquire release m = mask @n $ \ restore -> do + a <- acquire + r <- onException @n (restore $ m a) (release a) + r <$ release a + +-- | See @"Control.Exception".'Exc.bracket_'@. +-- +-- @since 1.1.0.2 +bracket_ + :: forall n sig m a b c + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m b + -> m c + -> m c +bracket_ before after thing = bracket @n before (const after) (const thing) + +-- | See @"Control.Exception".'Exc.bracketOnError'@. +-- +-- @since 1.1.0.2 +bracketOnError + :: forall n sig m a b c + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracketOnError acquire release m = mask @n $ \ restore -> do + a <- acquire + onException @n (restore $ m a) (release a) + +-- | See @"Control.Exception".'Exc.finally'@. +-- +-- @since 1.1.0.2 +finally + :: forall n sig m a b + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m b + -> m a +finally m sequel = mask @n $ + \ restore -> onException @n (restore m) sequel <* sequel + +-- | See @"Control.Exception".'Exc.onException'@. +-- +-- @since 1.1.0.2 +onException + :: forall n sig m a b + . (MonadUnliftIO n, Has (Lift n) sig m) + => m a + -> m b + -> m a +onException io what = catch @n io $ + \e -> what >> throwIO @n @Exc.SomeException e diff --git a/test/Main.hs b/test/Main.hs index 3b957cb..3cfa3d7 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Main where -import Prelude hiding (ioError) +import Prelude hiding (ioError) -import qualified Control.Carrier.State.IORef as IOState -import qualified Control.Carrier.State.Strict as State import Control.Carrier.Lift (runM) +import qualified Control.Carrier.State.IORef as IOState +import qualified Control.Carrier.State.Strict as State import Control.Effect.Exception import Control.Effect.State -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as HUnit +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit problematic :: (Has (Lift IO) sig m, Has (State Char) sig m) => m () problematic =