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