Revert original `Control.Effect.Exception` module.

This will keep semantics of `Control.Exception`.
main
Joshua Potter 2022-04-03 10:11:36 -04:00
parent be5f86bc03
commit e4aa4c78be
1 changed files with 48 additions and 34 deletions

View File

@ -2,7 +2,6 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
-- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. -- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
@ -13,7 +12,7 @@ module Control.Effect.Exception
, throwTo , throwTo
, catch , catch
, catches , catches
, U.Handler(..) , Handler(..)
, catchJust , catchJust
, handle , handle
, handleJust , handleJust
@ -44,7 +43,6 @@ module Control.Effect.Exception
) where ) where
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import qualified Control.Effect.Exception.UnliftIO as U
import Control.Effect.Lift import Control.Effect.Lift
import Control.Exception hiding import Control.Exception hiding
( Handler ( Handler
@ -75,37 +73,46 @@ import Control.Exception hiding
import qualified Control.Exception as Exc import qualified Control.Exception as Exc
import Prelude hiding (ioError) import Prelude hiding (ioError)
-- | See @"Unlift.Exception".throwIO@. -- | See @"Control.Exception".'Exc.throwIO'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
throwIO :: (Exc.Exception e, Has (Lift IO) sig m) => e -> m a throwIO :: (Exc.Exception e, Has (Lift IO) sig m) => e -> m a
throwIO = U.throwIO @IO throwIO = sendM . Exc.throwIO
-- | See @"Control.Exception".'Exc.ioError'@. -- | See @"Control.Exception".'Exc.ioError'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
ioError :: Has (Lift IO) sig m => IOError -> m a ioError :: Has (Lift IO) sig m => IOError -> m a
ioError = U.ioError @IO ioError = sendM . Exc.ioError
-- | See @"Control.Exception".'Exc.throwTo'@. -- | See @"Control.Exception".'Exc.throwTo'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
throwTo :: (Exc.Exception e, Has (Lift IO) sig m) => ThreadId -> e -> m () throwTo :: (Exc.Exception e, Has (Lift IO) sig m) => ThreadId -> e -> m ()
throwTo = U.throwTo @IO throwTo thread = sendM . Exc.throwTo thread
-- | See @"Control.Exception".catch@. -- | See @"Control.Exception".'Exc.catch'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
catch :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a catch :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a
catch = U.catch @IO catch m h = liftWith $ \ run ctx -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h)
-- | See @"Control.Exception".catches@. -- | See @"Control.Exception".'Exc.catches'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
catches :: Has (Lift IO) sig m => m a -> [U.Handler m a] -> m a catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a
catches = U.catches @IO catches m hs = liftWith $ \ run ctx ->
Exc.catches (run (m <$ ctx)) (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs)
-- | See @"Control.Exception".catchJust@. -- | 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'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
catchJust catchJust
@ -114,13 +121,13 @@ catchJust
-> m a -> m a
-> (b -> m a) -> (b -> m a)
-> m a -> m a
catchJust = U.catchJust @IO catchJust p m h = liftWith $ \ run ctx -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h)
-- | See @"Control.Exception".'Exc.handle'@. -- | See @"Control.Exception".'Exc.handle'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
handle :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a handle :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a
handle = U.handle @IO handle = flip catch
-- | See @"Control.Exception".'Exc.handleJust'@. -- | See @"Control.Exception".'Exc.handleJust'@.
-- --
@ -131,67 +138,69 @@ handleJust
-> (b -> m a) -> (b -> m a)
-> m a -> m a
-> m a -> m a
handleJust = U.handleJust @IO handleJust p = flip (catchJust p)
-- | See @"Control.Exception".'Exc.try'@. -- | See @"Control.Exception".'Exc.try'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
try :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> m (Either e a) try :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> m (Either e a)
try = U.try @IO try m = (Right <$> m) `catch` (pure . Left)
-- | See @"Control.Exception".'Exc.tryJust'@. -- | See @"Control.Exception".'Exc.tryJust'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
tryJust :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> Maybe b) -> m a -> m (Either b a) tryJust :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> Maybe b) -> m a -> m (Either b a)
tryJust = U.tryJust @IO tryJust p m = catchJust p (Right <$> m) (pure . Left)
-- | See @"Control.Exception".evaluate@. -- | See @"Control.Exception".'Exc.evaluate'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
evaluate :: Has (Lift IO) sig m => a -> m a evaluate :: Has (Lift IO) sig m => a -> m a
evaluate = U.evaluate @IO evaluate = sendM . Exc.evaluate
-- | See @"Control.Exception".mask@. -- | See @"Control.Exception".'Exc.mask'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b
mask = U.mask @IO mask with = liftWith $ \ run ctx -> Exc.mask $ \ restore ->
run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx)
-- | See @"Control.Exception".'Exc.mask_'@. -- | See @"Control.Exception".'Exc.mask_'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
mask_ :: Has (Lift IO) sig m => m a -> m a mask_ :: Has (Lift IO) sig m => m a -> m a
mask_ = U.mask_ @IO mask_ m = mask (\_ -> m)
-- | See @"Control.Exception".uninterruptibleMask@. -- | See @"Control.Exception".'Exc.uninterruptibleMask'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
uninterruptibleMask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b uninterruptibleMask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b
uninterruptibleMask = U.uninterruptibleMask @IO uninterruptibleMask with = liftWith $ \ run ctx -> Exc.uninterruptibleMask $ \ restore ->
run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx)
-- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. -- | See @"Control.Exception".'Exc.uninterruptibleMask_'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
uninterruptibleMask_ :: Has (Lift IO) sig m => m a -> m a uninterruptibleMask_ :: Has (Lift IO) sig m => m a -> m a
uninterruptibleMask_ = U.uninterruptibleMask_ @IO uninterruptibleMask_ m = uninterruptibleMask (\_ -> m)
-- | See @"Control.Exception".'Exc.getMaskingState'@. -- | See @"Control.Exception".'Exc.getMaskingState'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
getMaskingState :: Has (Lift IO) sig m => m Exc.MaskingState getMaskingState :: Has (Lift IO) sig m => m Exc.MaskingState
getMaskingState = U.getMaskingState @IO getMaskingState = sendM Exc.getMaskingState
-- | See @"Control.Exception".'Exc.interruptible'@. -- | See @"Control.Exception".'Exc.interruptible'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
interruptible :: Has (Lift IO) sig m => m a -> m a interruptible :: Has (Lift IO) sig m => m a -> m a
interruptible = U.interruptible @IO interruptible m = liftWith $ \ run ctx -> Exc.interruptible (run (m <$ ctx))
-- | See @"Control.Exception".'Exc.allowInterrupt'@. -- | See @"Control.Exception".'Exc.allowInterrupt'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
allowInterrupt :: Has (Lift IO) sig m => m () allowInterrupt :: Has (Lift IO) sig m => m ()
allowInterrupt = U.allowInterrupt @IO allowInterrupt = sendM Exc.allowInterrupt
-- | See @"Control.Exception".'Exc.bracket'@. -- | See @"Control.Exception".'Exc.bracket'@.
-- --
@ -202,7 +211,10 @@ bracket
-> (a -> m b) -> (a -> m b)
-> (a -> m c) -> (a -> m c)
-> m c -> m c
bracket = U.bracket @IO bracket acquire release m = mask $ \ restore -> do
a <- acquire
r <- restore (m a) `onException` release a
r <$ release a
-- | See @"Control.Exception".'Exc.bracket_'@. -- | See @"Control.Exception".'Exc.bracket_'@.
-- --
@ -213,7 +225,7 @@ bracket_
-> m b -> m b
-> m c -> m c
-> m c -> m c
bracket_ = U.bracket_ @IO bracket_ before after thing = bracket before (const after) (const thing)
-- | See @"Control.Exception".'Exc.bracketOnError'@. -- | See @"Control.Exception".'Exc.bracketOnError'@.
-- --
@ -224,7 +236,9 @@ bracketOnError
-> (a -> m b) -> (a -> m b)
-> (a -> m c) -> (a -> m c)
-> m c -> m c
bracketOnError = U.bracketOnError @IO bracketOnError acquire release m = mask $ \ restore -> do
a <- acquire
restore (m a) `onException` release a
-- | See @"Control.Exception".'Exc.finally'@. -- | See @"Control.Exception".'Exc.finally'@.
-- --
@ -234,10 +248,10 @@ finally
=> m a => m a
-> m b -> m b
-> m a -> m a
finally = U.finally @IO finally m sequel = mask $ \ restore -> (restore m `onException` sequel) <* sequel
-- | See @"Control.Exception".'Exc.onException'@. -- | See @"Control.Exception".'Exc.onException'@.
-- --
-- @since 1.0.0.0 -- @since 1.0.0.0
onException :: Has (Lift IO) sig m => m a -> m b -> m a onException :: Has (Lift IO) sig m => m a -> m b -> m a
onException = U.onException @IO onException io what = io `catch` \e -> what >> throwIO (e :: Exc.SomeException)