From a39a61861d4c9c3e35b5523158c3395bbce545b5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 12:22:20 -0400 Subject: [PATCH] Add Control.Effect.Exception. --- cabal.project | 6 + src/Control/Effect/Exception.hs | 254 ++++++++++++++++++++++++++++++++ 2 files changed, 260 insertions(+) create mode 100644 cabal.project create mode 100644 src/Control/Effect/Exception.hs diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..724efbd --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/fused-effects/fused-effects.git + tag: 0c7d9c19b638f7fe21ac77903894308ad15b0e80 diff --git a/src/Control/Effect/Exception.hs b/src/Control/Effect/Exception.hs new file mode 100644 index 0000000..05e571e --- /dev/null +++ b/src/Control/Effect/Exception.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DeriveFunctor, ExistentialQuantification, RankNTypes, StandaloneDeriving #-} +-- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +-- +-- @since 1.0.0.0 +module Control.Effect.Exception +( -- * 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 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 + , allowInterrupt + , bracket + , bracket_ + , bracketOnError + , finally + , onException + ) +import qualified Control.Exception as Exc +import Prelude hiding (ioError) + +-- | See @"Control.Exception".'Exc.throwIO'@. +-- +-- @since 1.0.0.0 +throwIO :: (Exc.Exception e, Has (Lift IO) sig m) => e -> m a +throwIO = sendM . Exc.throwIO + +-- | See @"Control.Exception".'Exc.ioError'@. +-- +-- @since 1.0.0.0 +ioError :: Has (Lift IO) sig m => IOError -> m a +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 thread = sendM . Exc.throwTo thread + +-- | 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 m h = liftWith $ \ ctx run -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h) + +-- | See @"Control.Exception".'Exc.catches'@. +-- +-- @since 1.0.0.0 +catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a +catches m hs = liftWith $ \ ctx run -> + Exc.catches (run (m <$ ctx)) (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs) + +-- | 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 + :: (Exc.Exception e, Has (Lift IO) sig m) + => (e -> Maybe b) + -> m a + -> (b -> m a) + -> m a +catchJust p m h = liftWith $ \ ctx run -> 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 = flip catch + +-- | See @"Control.Exception".'Exc.handleJust'@. +-- +-- @since 1.0.0.0 +handleJust + :: (Exc.Exception e, Has (Lift IO) sig m) + => (e -> Maybe b) + -> (b -> m a) + -> m a + -> m a +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 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 p m = catchJust p (Right <$> m) (pure . Left) + +-- | See @"Control.Exception".'Exc.evaluate'@. +-- +-- @since 1.0.0.0 +evaluate :: Has (Lift IO) sig m => a -> m a +evaluate = sendM . Exc.evaluate + +-- | 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 with = liftWith $ \ ctx run -> Exc.mask $ \ restore -> + run (with (\ m -> liftWith $ \ ctx' run' -> 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_ m = mask $ const m + +-- | 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 with = liftWith $ \ ctx run -> Exc.uninterruptibleMask $ \ restore -> + run (with (\ m -> liftWith $ \ ctx' run' -> 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_ m = uninterruptibleMask $ const m + +-- | See @"Control.Exception".'Exc.getMaskingState'@. +-- +-- @since 1.0.0.0 +getMaskingState :: Has (Lift IO) sig m => m Exc.MaskingState +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 m = liftWith $ \ ctx run -> Exc.interruptible (run (m <$ ctx)) + +-- | See @"Control.Exception".'Exc.allowInterrupt'@. +-- +-- @since 1.0.0.0 +allowInterrupt :: Has (Lift IO) sig m => m () +allowInterrupt = sendM Exc.allowInterrupt + +-- | See @"Control.Exception".'Exc.bracket'@. +-- +-- @since 1.0.0.0 +bracket + :: Has (Lift IO) sig m + => m a + -> (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 + +-- | See @"Control.Exception".'Exc.bracket_'@. +-- +-- @since 1.0.0.0 +bracket_ + :: Has (Lift IO) sig m + => m a + -> m b + -> m c + -> m c +bracket_ before after thing = bracket before (const after) (const thing) + +-- | See @"Control.Exception".'Exc.bracketOnError'@. +-- +-- @since 1.0.0.0 +bracketOnError + :: Has (Lift IO) sig m + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracketOnError acquire release m = mask $ \ restore -> do + a <- acquire + restore (m a) `onException` release a + +-- | See @"Control.Exception".'Exc.finally'@. +-- +-- @since 1.0.0.0 +finally + :: Has (Lift IO) sig m + => m a + -> m b + -> m a +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 io what = io `catch` \e -> what >> throwIO (e :: Exc.SomeException)