{-|
Module : Control.Monad.Freer.Catching
Description : Handle exceptions that are thrown during interpreation of free monad effects, at call time.
Copyright : (c) Ben Weitzman 2018
License : MIT
Maintainer : ben@costarastrolgoy.com
Stability : experimental
Portability : POSIX
The 'Catching' effect allows a way to keep track of effects that we might expect to throw
exceptions during their handling, but whose signatures don't indicate this.
As an example, consider an effect @Div@ that divides numbers:
@
data Div a where
Div :: Int -> Int -> Div Int
@
The keen programmer is aware that this can throw an error. However, suppose that there is reason to believe that
this effect will be rarely used in a way that fails. Adding an indicator to the interface (such as by saying @Div :: Int -> Int -> Div (Maybe Int)@) makes using this effect more annoying most of the time.
Nevertheless, it should be possible to handle this case when we want to. This is where 'Catching' can help.
-}
module Control.Monad.Freer.Catching
(Catching
,catching
,runCatching
,runCatching2
)
where
import Control.Exception
import Control.Monad
import Control.Monad.Freer
import Control.Monad.Freer.Internal
import Data.OpenUnion.Internal
-- | The 'Catching' effect is parameterized by the effect it is handling and the type of exceptions it will
-- attempt to handle (e.g. @Catching Div ArithException@)
data Catching f e a where
Catching :: forall f e a . (Exception e)
=> (forall r . Member f r => Eff r a)
-> Catching f e (Either e a)
-- | @catching@ will turn an effectful computation producing an @a@ and using effect @f@ into one that produces
-- an @Either e a@. This allows any exception that is thrown during normal handling of @f@ be handled explicitly.
catching :: forall e f a r
. (Exception e, Member (Catching f e) r)
=> Eff '[f] a
-> Eff r (Either e a)
catching f = send @(Catching f e) $ Catching (generalize f)
generalize :: Member f r => Eff '[f] a -> Eff r a
generalize (Val x) = return x
generalize (E u' q) = send (extract u') >>= qComp q generalize
-- | Handle an effect @f@ and a @Catching f e@ simultaneously. In cases where 'catching' was called, on an
-- effect, exceptions of type @e@ will be caught and handled. In cases where 'catching' was not called but
-- @f@ was used directly, exceptions will not be caught and will bubble up.
runCatching :: forall e r v f
. (Member IO r, LastMember IO (f ': r))
=> (forall a q . Member IO q => Eff (f ': q) a -> Eff q a)
-> Eff (Catching f e : f : r) v
-> Eff r v
runCatching runner = runner . interpretM handler
where handler :: Catching f e a -> IO a
handler (Catching f) = do
x <- try . runM $ evaluate <$> runner f
case x of
Left e -> return $ Left e
Right y -> try y
-- | 'runCatching2' can catch exceptions in effects that don't interpret directly to 'IO' but instead
-- go through an intermediary effect. In this case, three effects will be handled in one go:
--
-- * The effect @f@ that is being called and is expected to be the source of an exception
-- * The effect @g@ which is not being called directly but is called instead by the handler @f@
-- * The effect @Catching f e@
runCatching2 :: forall e r v f g
. (Member IO r, Member IO (f : r), LastMember IO (f : g : r))
=> (forall a q. Member g q => Eff (f : q) a -> Eff q a)
-> (forall a q. Member IO q => Eff (g : q) a -> Eff q a)
-> Eff (Catching f e : f : g : r) v
-> Eff r v
runCatching2 runner1 runner2 = runner2 . runner1 . interpretM handler
where handler :: Catching f e a -> IO a
handler (Catching f) = do
x <- try . runM $ evaluate <$> (runner2 . runner1 $ f)
case x of
Left e -> return $ Left e
Right y -> try y