Add `UnliftIO` support, passing through stylish-haskell.
parent
f584509b44
commit
c4014f49c6
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <version>
|
||||
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
|
||||
|
|
@ -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 <version>
|
||||
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
|
||||
13
test/Main.hs
13
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 =
|
||||
|
|
|
|||
Loading…
Reference in New Issue