Add Control.Effect.Exception.
Patrick Thomson
parent
65fa041be3
commit
a39a61861d
|
|
@ -0,0 +1,6 @@
|
|||
packages: .
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/fused-effects/fused-effects.git
|
||||
tag: 0c7d9c19b638f7fe21ac77903894308ad15b0e80
|
||||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue