diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 6eceb2e..90660b9 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -32,14 +32,13 @@ library hs-source-dirs: src exposed-modules: Control.Effect.Exception - Control.Effect.Exception.UnliftIO - other-modules: - Control.Effect.Exception.Internal + Control.Effect.UnliftIO.Exception build-depends: base >= 4.7 && < 5 , fused-effects >= 1.1 , transformers >= 0.4 && < 0.6 , unliftio-core >= 0.2 && < 0.3 + , unliftio >= 0.2 && < 0.3 test-suite test import: common diff --git a/src/Control/Effect/Exception/Internal.hs b/src/Control/Effect/Exception/Internal.hs deleted file mode 100644 index 4934e94..0000000 --- a/src/Control/Effect/Exception/Internal.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# 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/UnliftIO/Exception.hs similarity index 51% rename from src/Control/Effect/Exception/UnliftIO.hs rename to src/Control/Effect/UnliftIO/Exception.hs index 010b4fc..5ee7cd4 100644 --- a/src/Control/Effect/Exception/UnliftIO.hs +++ b/src/Control/Effect/UnliftIO/Exception.hs @@ -5,13 +5,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} --- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +-- | Operations from "UnliftIO.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. -- --- @since 1.1.2.0 -module Control.Effect.Exception.UnliftIO -( -- * Lifted "Control.Exception" operations +-- @since 1.1.2.1 +module Control.Effect.UnliftIO.Exception +( -- * Lifted "UnliftIO.Exception" operations throwIO -, ioError , throwTo , catch , catches @@ -26,9 +25,6 @@ module Control.Effect.Exception.UnliftIO , mask_ , uninterruptibleMask , uninterruptibleMask_ -, getMaskingState -, interruptible -, allowInterrupt , bracket , bracket_ , bracketOnError @@ -46,11 +42,9 @@ module Control.Effect.Exception.UnliftIO ) 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_ @@ -59,11 +53,8 @@ import Control.Exception hiding , catches , evaluate , finally - , getMaskingState , handle , handleJust - , interruptible - , ioError , mask , mask_ , onException @@ -74,44 +65,34 @@ import Control.Exception hiding , uninterruptibleMask , uninterruptibleMask_ ) -import qualified Control.Exception as EUnsafe import Control.Monad.IO.Unlift (MonadIO, MonadUnliftIO, liftIO, withRunInIO) import Prelude hiding (ioError) +import qualified UnliftIO.Exception as Exc --- | See @"Control.Exception".throwIO@. +-- | See @"UnliftIO.Exception".'Exc.throwIO'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 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 +throwIO = sendM @n . liftIO . Exc.throwIO --- | See @"Control.Exception".'Exc.ioError'@. +-- | See @"UnliftIO.Exception".'Exc.throwTo'@. -- --- @since 1.1.2.0 -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.2.0 +-- @since 1.1.2.1 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 +throwTo thread = sendM @n . liftIO . Exc.throwTo thread --- | See @"Control.Exception".catch@. +-- | See @"UnliftIO.Exception".'Exc.catch'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 catch :: forall n e sig m a . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -119,33 +100,33 @@ catch -> (e -> m a) -> m a catch m h = liftWith @n $ - \run ctx -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h) + \hdl ctx -> hdl (m <$ ctx) `Exc.catch` (hdl . (<$ ctx) . h) --- | See @"Control.Exception".catches@. +-- | See @"UnliftIO.Exception".'Exc.catches'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 catches :: forall n sig m a . (MonadUnliftIO n, Has (Lift n) sig m) => m a - -> [Handler m a] + -> [Exc.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) + \ hdl ctx -> Exc.catches + (hdl (m <$ ctx)) + (map (\ (Exc.Handler h) -> Exc.Handler (hdl . (<$ ctx) . h)) hs) --- | See @"Control.Exception".'Exc.Handler'@. +-- | See @"UnliftIO.Exception".'Exc.Handler'@. -- --- @since +-- @since 1.1.2.1 data Handler m a = forall e . Exc.Exception e => Handler (e -> m a) deriving instance Functor m => Functor (Handler m) --- | See @"Control.Exception".catchJust@. +-- | See @"UnliftIO.Exception".'Exc.catchJust'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 catchJust :: forall n e sig m a b . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -154,11 +135,11 @@ catchJust -> (b -> m a) -> m a catchJust p m h = liftWith @n $ - \ run ctx -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h) + \ hdl ctx -> Exc.catchJust p (hdl (m <$ ctx)) (hdl . (<$ ctx) . h) --- | See @"Control.Exception".'Exc.handle'@. +-- | See @"UnliftIO.Exception".'Exc.handle'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 handle :: forall n e sig m a . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -167,9 +148,9 @@ handle -> m a handle = flip $ catch @n --- | See @"Control.Exception".'Exc.handleJust'@. +-- | See @"UnliftIO.Exception".'Exc.handleJust'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 handleJust :: forall n e sig m a b . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -179,9 +160,9 @@ handleJust -> m a handleJust p = flip (catchJust @n p) --- | See @"Control.Exception".'Exc.try'@. +-- | See @"UnliftIO.Exception".'Exc.try'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 try :: forall n e sig m a b . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -189,9 +170,9 @@ try -> m (Either e a) try m = catch @n (Right <$> m) (pure . Left) --- | See @"Control.Exception".'Exc.tryJust'@. +-- | See @"UnliftIO.Exception".'Exc.tryJust'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 tryJust :: forall n e sig m a b . (MonadUnliftIO n, Exc.Exception e, Has (Lift n) sig m) @@ -200,26 +181,26 @@ tryJust -> m (Either b a) tryJust p m = catchJust @n p (Right <$> m) (pure . Left) --- | See @"Control.Exception".evaluate@. +-- | See @"UnliftIO.Exception".evaluate@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 evaluate :: forall n sig m a. (MonadUnliftIO n, Has (Lift n) sig m) => a -> m a evaluate = sendM @n . Exc.evaluate --- | See @"Control.Exception".mask@. +-- | See @"UnliftIO.Exception".mask@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 mask :: forall n sig m a b . (MonadUnliftIO n, Has (Lift n) sig m) - => ((forall a . m a -> m a) -> m b) + => ((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) +mask with = liftWith @n $ \ hdl ctx -> Exc.mask $ \ restore -> + hdl (with (\ m -> liftWith $ \ hdl' ctx' -> restore (hdl' (m <$ ctx'))) <$ ctx) --- | See @"Control.Exception".'Exc.mask_'@. +-- | See @"UnliftIO.Exception".'Exc.mask_'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 mask_ :: forall n sig m a . (MonadUnliftIO n, Has (Lift n) sig m) @@ -227,22 +208,22 @@ mask_ -> m a mask_ m = mask @n (const m) --- | See @"Control.Exception".uninterruptibleMask@. +-- | See @"UnliftIO.Exception".uninterruptibleMask@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 uninterruptibleMask :: forall n sig m a b . (MonadUnliftIO n, Has (Lift n) sig m) - => ((forall a . m a -> m a) -> m b) + => ((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) + \ hdl ctx -> Exc.uninterruptibleMask $ \ restore -> + hdl (with (\ m -> liftWith $ + \ hdl' ctx' -> restore (hdl' (m <$ ctx'))) <$ ctx) --- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. +-- | See @"UnliftIO.Exception".'Exc.uninterruptibleMask_'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 uninterruptibleMask_ :: forall n sig m a . (MonadUnliftIO n, Has (Lift n) sig m) @@ -250,38 +231,9 @@ uninterruptibleMask_ -> m a uninterruptibleMask_ m = uninterruptibleMask @n (const m) --- | See @"Control.Exception".'Exc.getMaskingState'@. +-- | See @"UnliftIO.Exception".'Exc.bracket'@. -- --- @since 1.1.2.0 -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.2.0 -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.2.0 -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.2.0 +-- @since 1.1.2.1 bracket :: forall n sig m a b c . (MonadUnliftIO n, Has (Lift n) sig m) @@ -289,14 +241,12 @@ bracket -> (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 +bracket acquire release m = liftWith @n $ \ hdl ctx -> + Exc.bracket (hdl (acquire <$ ctx)) (hdl . (release <$>)) (hdl . (m <$>)) --- | See @"Control.Exception".'Exc.bracket_'@. +-- | See @"UnliftIO.Exception".'Exc.bracket_'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 bracket_ :: forall n sig m a b c . (MonadUnliftIO n, Has (Lift n) sig m) @@ -306,9 +256,9 @@ bracket_ -> m c bracket_ before after thing = bracket @n before (const after) (const thing) --- | See @"Control.Exception".'Exc.bracketOnError'@. +-- | See @"UnliftIO.Exception".'Exc.bracketOnError'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 bracketOnError :: forall n sig m a b c . (MonadUnliftIO n, Has (Lift n) sig m) @@ -316,30 +266,32 @@ bracketOnError -> (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) +bracketOnError acquire release m = liftWith @n $ \ hdl ctx -> + Exc.bracketOnError + (hdl (acquire <$ ctx)) + (hdl . (release <$>)) + (hdl . (m <$>)) --- | See @"Control.Exception".'Exc.finally'@. +-- | See @"UnliftIO.Exception".'Exc.finally'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 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 +finally m sequel = liftWith @n $ \ hdl ctx -> + Exc.finally (hdl (m <$ ctx)) (hdl (sequel <$ ctx)) --- | See @"Control.Exception".'Exc.onException'@. +-- | See @"UnliftIO.Exception".'Exc.onException'@. -- --- @since 1.1.2.0 +-- @since 1.1.2.1 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 +onException io what = liftWith @n $ \ hdl ctx -> + Exc.onException (hdl (io <$ ctx)) (hdl (what <$ ctx))