Catching.hs

{-|
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