{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Control.Eff.ExceptionExtra
( liftTry
, maybeThrow
, module Eff
)
where
import qualified Control.Exception.Safe as Safe
import qualified Control.Monad.Catch as Catch
import Control.Eff
import Control.Eff.Extend
import Control.Eff.Lift
import Control.Eff.Exception as Eff
import GHC.Stack
import Control.Eff.Reader.Lazy as Lazy
import Control.Eff.Reader.Strict as Strict
liftTry
:: forall e r a
. (HasCallStack, Safe.Exception e, Lifted IO r)
=> Eff r a
-> Eff r (Either e a)
liftTry m = (Right <$> m) `catchDynE` (return . Left)
maybeThrow :: Member (Eff.Exc x) e => x -> Maybe a -> Eff e a
maybeThrow x = Eff.liftEither . maybe (Left x) Right
instance Catch.MonadThrow (Eff e) => Catch.MonadThrow (Eff (Lazy.Reader x ': e)) where
throwM exception = raise (Catch.throwM exception)
instance Catch.MonadCatch (Eff e) => Catch.MonadCatch (Eff (Lazy.Reader x ': e)) where
catch effect handler = do
readerValue <- Lazy.ask @x
let nestedEffects =
Lazy.runReader readerValue effect
nestedHandler exception =
Lazy.runReader readerValue (handler exception)
raise (Catch.catch nestedEffects nestedHandler)
instance Catch.MonadMask (Eff e) => Catch.MonadMask (Eff (Lazy.Reader x ': e)) where
mask maskedEffect = do
readerValue <- Lazy.ask @x
raise
(Catch.mask
(\nestedUnmask -> Lazy.runReader
readerValue
(maskedEffect
(\unmasked ->
raise (nestedUnmask (Lazy.runReader readerValue unmasked))
)
)
)
)
uninterruptibleMask maskedEffect = do
readerValue <- Lazy.ask @x
raise
(Catch.uninterruptibleMask
(\nestedUnmask -> Lazy.runReader
readerValue
(maskedEffect
(\unmasked ->
raise (nestedUnmask (Lazy.runReader readerValue unmasked))
)
)
)
)
generalBracket acquire release use = do
readerValue <- Lazy.ask @x
let
lower :: Eff (Lazy.Reader x ': e) a -> Eff e a
lower = Lazy.runReader readerValue
raise
(Catch.generalBracket
(lower acquire)
(((.).(.)) lower release)
(lower . use))
instance Catch.MonadThrow (Eff e) => Catch.MonadThrow (Eff (Strict.Reader x ': e)) where
throwM exception = raise (Catch.throwM exception)
instance Catch.MonadCatch (Eff e) => Catch.MonadCatch (Eff (Strict.Reader x ': e)) where
catch effect handler = do
readerValue <- Strict.ask @x
let nestedEffects =
Strict.runReader readerValue effect
nestedHandler exception =
Strict.runReader readerValue (handler exception)
raise (Catch.catch nestedEffects nestedHandler)
instance Catch.MonadMask (Eff e) => Catch.MonadMask (Eff (Strict.Reader x ': e)) where
mask maskedEffect = do
readerValue <- Strict.ask @x
raise
(Catch.mask
(\nestedUnmask -> Strict.runReader
readerValue
(maskedEffect
(\unmasked ->
raise (nestedUnmask (Strict.runReader readerValue unmasked))
)
)
)
)
uninterruptibleMask maskedEffect = do
readerValue <- Strict.ask @x
raise
(Catch.uninterruptibleMask
(\nestedUnmask -> Strict.runReader
readerValue
(maskedEffect
(\unmasked ->
raise (nestedUnmask (Strict.runReader readerValue unmasked))
)
)
)
)
generalBracket acquire release use = do
readerValue <- Strict.ask @x
let
lower :: Eff (Strict.Reader x ': e) a -> Eff e a
lower = Strict.runReader readerValue
raise
(Catch.generalBracket
(lower acquire)
(((.).(.)) lower release)
(lower . use))
instance Catch.MonadThrow m => Catch.MonadThrow (Eff '[Lift m]) where
throwM exception = lift (Catch.throwM exception)
instance Catch.MonadCatch m => Catch.MonadCatch (Eff '[Lift m]) where
catch effect handler = do
let nestedEffects = runLift effect
nestedHandler exception = runLift (handler exception)
lift (Catch.catch nestedEffects nestedHandler)
instance Catch.MonadMask m => Catch.MonadMask (Eff '[Lift m]) where
mask maskedEffect =
lift
(Catch.mask
(\nestedUnmask -> runLift
(maskedEffect
(\unmasked -> lift (nestedUnmask (runLift unmasked))
)
)
)
)
uninterruptibleMask maskedEffect =
lift
(Catch.uninterruptibleMask
(\nestedUnmask -> runLift
(maskedEffect
(\unmasked ->
lift (nestedUnmask (runLift unmasked))
)
)
)
)
generalBracket acquire release use =
lift
(Catch.generalBracket
(runLift acquire)
(((.).(.)) runLift release)
(runLift . use))
instance Catch.MonadThrow (Eff e) => Catch.MonadThrow (Eff (Exc x ': e)) where
throwM exception = raise (Catch.throwM exception)
instance Catch.MonadCatch (Eff e) => Catch.MonadCatch (Eff (Exc x ': e)) where
catch effect handler = do
let nestedEffects =
runError effect
nestedHandler exception =
runError (handler exception)
errorOrResult <- raise (Catch.catch nestedEffects nestedHandler)
liftEither errorOrResult
instance Catch.MonadMask (Eff e) => Catch.MonadMask (Eff (Exc x ': e)) where
mask maskedEffect = do
errorOrResult <- raise
(Catch.mask
(\nestedUnmask -> runError
(maskedEffect
(\unmasked -> do
errorOrResult <- raise (nestedUnmask (runError unmasked))
liftEither errorOrResult
)
)
)
)
liftEither errorOrResult
uninterruptibleMask maskedEffect = do
errorOrResult <- raise
(Catch.uninterruptibleMask
(\nestedUnmask -> runError
(maskedEffect
(\unmasked -> do
errorOrResult <- raise (nestedUnmask (runError unmasked))
liftEither errorOrResult
)
)
)
)
liftEither errorOrResult
generalBracket acquire release use = do
(useResultOrError, releaseResultOrError) <- raise
(Catch.generalBracket
(runError acquire)
(\resourceRight exitCase ->
case resourceRight of
Left e -> return (Left e)
Right resource ->
case exitCase of
Catch.ExitCaseSuccess (Right b) -> runError (release resource (Catch.ExitCaseSuccess b))
Catch.ExitCaseException e -> runError (release resource (Catch.ExitCaseException e))
_ -> runError (release resource Catch.ExitCaseAbort)
)
(\case
Left e -> return (Left e)
Right resource -> runError (use resource)))
c <- liftEither releaseResultOrError
b <- liftEither useResultOrError
return (b, c)