{-# LANGUAGE AllowAmbiguousTypes         #-}
{-# LANGUAGE FlexibleContexts            #-}
{-# LANGUAGE GADTs                       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
{-# LANGUAGE RankNTypes                  #-}
{-# LANGUAGE ScopedTypeVariables         #-}
{-# LANGUAGE TypeApplications            #-}
{-# LANGUAGE UndecidableInstances        #-}

module Polysemy.ConstraintAbsorber.MonadCatch
  (
    -- * Constraint Absorbers
    absorbMonadThrow
  , absorbMonadCatch
  -- * run helper
  , runMonadCatch
  , runMonadCatchAsText
    -- * Re-exports
  , Exception(..)
  , SomeException
  )
where

import qualified Control.Monad.Catch           as C
import           Control.Monad.Catch            ( Exception(..)
                                                , SomeException
                                                , toException
                                                )

import qualified Data.Text                     as T
import           Polysemy
import           Polysemy.ConstraintAbsorber
import qualified Polysemy.Error                as E


------------------------------------------------------------------------------
-- | Like 'E.runError' but applies a given function from 'SomeException'
-- to some other type, typically something less opaque.
-- e.g.:
--  @runMonadCatch C.displayException@
-- 
-- @since 0.7.0.0
runMonadCatch
  :: Exception e
  => (Maybe e -> e')
  -> Sem (E.Error C.SomeException : E.Error e' : r) a
  -> Sem r (Either e' a)
runMonadCatch :: (Maybe e -> e')
-> Sem (Error SomeException : Error e' : r) a
-> Sem r (Either e' a)
runMonadCatch Maybe e -> e'
f = Sem (Error e' : r) a -> Sem r (Either e' a)
forall e (r :: [(* -> *) -> * -> *]) a.
Sem (Error e : r) a -> Sem r (Either e a)
E.runError (Sem (Error e' : r) a -> Sem r (Either e' a))
-> (Sem (Error SomeException : Error e' : r) a
    -> Sem (Error e' : r) a)
-> Sem (Error SomeException : Error e' : r) a
-> Sem r (Either e' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> e')
-> Sem (Error SomeException : Error e' : r) a
-> Sem (Error e' : r) a
forall e1 e2 (r :: [(* -> *) -> * -> *]) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
E.mapError (Maybe e -> e'
f (Maybe e -> e')
-> (SomeException -> Maybe e) -> SomeException -> e'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
C.fromException)

runMonadCatchAsText
  :: Sem (E.Error C.SomeException : E.Error T.Text : r) a
  -> Sem r (Either T.Text a)
runMonadCatchAsText :: Sem (Error SomeException : Error Text : r) a
-> Sem r (Either Text a)
runMonadCatchAsText = Sem (Error Text : r) a -> Sem r (Either Text a)
forall e (r :: [(* -> *) -> * -> *]) a.
Sem (Error e : r) a -> Sem r (Either e a)
E.runError (Sem (Error Text : r) a -> Sem r (Either Text a))
-> (Sem (Error SomeException : Error Text : r) a
    -> Sem (Error Text : r) a)
-> Sem (Error SomeException : Error Text : r) a
-> Sem r (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> Text)
-> Sem (Error SomeException : Error Text : r) a
-> Sem (Error Text : r) a
forall e1 e2 (r :: [(* -> *) -> * -> *]) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
E.mapError (String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
C.displayException)



-- | Introduce a local 'S.MonadCatch' constraint on 'Sem' --- allowing it to
-- interop nicely with exceptions
--
-- @since 0.7.0.0
absorbMonadCatch
  :: Member (E.Error C.SomeException) r
  => (C.MonadCatch (Sem r) => Sem r a)
       -- ^ A computation that requires an instance of 'C.MonadCatch'
       -- or 'C.MonadThrow' for
       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.
  -> Sem r a
absorbMonadCatch :: (MonadCatch (Sem r) => Sem r a) -> Sem r a
absorbMonadCatch =
  CatchDict (Sem r)
-> (forall s.
    Reifies s (CatchDict (Sem r)) :- MonadCatch (Action (Sem r) s))
-> (MonadCatch (Sem r) => Sem r a)
-> Sem r a
forall (p :: (* -> *) -> Constraint) (x :: (* -> *) -> * -> * -> *)
       d (r :: [(* -> *) -> * -> *]) a.
d
-> (forall s. Reifies s d :- p (x (Sem r) s))
-> (p (Sem r) => Sem r a)
-> Sem r a
absorbWithSem @C.MonadCatch @Action ((forall a. SomeException -> Sem r a)
-> (forall a. Sem r a -> (SomeException -> Sem r a) -> Sem r a)
-> CatchDict (Sem r)
forall k (m :: k -> *).
(forall (a :: k). SomeException -> m a)
-> (forall (a :: k). m a -> (SomeException -> m a) -> m a)
-> CatchDict m
CatchDict forall a. SomeException -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
E.throw forall a. Sem r a -> (SomeException -> Sem r a) -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
E.catch) ((Reifies s (CatchDict (Sem r)) =>
 Dict (MonadCatch (Action (Sem r) s)))
-> Reifies s (CatchDict (Sem r)) :- MonadCatch (Action (Sem r) s)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub Reifies s (CatchDict (Sem r)) =>
Dict (MonadCatch (Action (Sem r) s))
forall (a :: Constraint). a => Dict a
Dict)
{-# INLINABLE absorbMonadCatch #-}

-- | Introduce a local 'S.MonadThrow' constraint on 'Sem' --- allowing it to
-- interop nicely with exceptions
--
-- @since 0.7.0.0
absorbMonadThrow
  :: Member (E.Error C.SomeException) r
  => (C.MonadThrow (Sem r) => Sem r a)
       -- ^ A computation that requires an instance of 'C.MonadCatch'
       -- or 'C.MonadThrow' for
       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.
  -> Sem r a
absorbMonadThrow :: (MonadThrow (Sem r) => Sem r a) -> Sem r a
absorbMonadThrow MonadThrow (Sem r) => Sem r a
main = (MonadCatch (Sem r) => Sem r a) -> Sem r a
forall (r :: [(* -> *) -> * -> *]) a.
Member (Error SomeException) r =>
(MonadCatch (Sem r) => Sem r a) -> Sem r a
absorbMonadCatch MonadThrow (Sem r) => Sem r a
MonadCatch (Sem r) => Sem r a
main
{-# INLINABLE absorbMonadThrow #-}

------------------------------------------------------------------------------
-- | A dictionary of the functions we need to supply
-- to make an instance of Error
data CatchDict m = CatchDict
  { CatchDict m -> forall (a :: k). SomeException -> m a
throwM_ :: forall a. C.SomeException -> m a
  , CatchDict m
-> forall (a :: k). m a -> (SomeException -> m a) -> m a
catch_ :: forall a. m a -> (C.SomeException -> m a) -> m a
  }


------------------------------------------------------------------------------
-- | Wrapper for a monadic action with phantom
-- type parameter for reflection.
-- Locally defined so that the instance we are going
-- to build with reflection must be coherent, that is
-- there cannot be orphans.
newtype Action m s' a = Action { Action m s' a -> m a
action :: m a }
  deriving (a -> Action m s' b -> Action m s' a
(a -> b) -> Action m s' a -> Action m s' b
(forall a b. (a -> b) -> Action m s' a -> Action m s' b)
-> (forall a b. a -> Action m s' b -> Action m s' a)
-> Functor (Action m s')
forall a b. a -> Action m s' b -> Action m s' a
forall a b. (a -> b) -> Action m s' a -> Action m s' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) k (s' :: k) a b.
Functor m =>
a -> Action m s' b -> Action m s' a
forall (m :: * -> *) k (s' :: k) a b.
Functor m =>
(a -> b) -> Action m s' a -> Action m s' b
<$ :: a -> Action m s' b -> Action m s' a
$c<$ :: forall (m :: * -> *) k (s' :: k) a b.
Functor m =>
a -> Action m s' b -> Action m s' a
fmap :: (a -> b) -> Action m s' a -> Action m s' b
$cfmap :: forall (m :: * -> *) k (s' :: k) a b.
Functor m =>
(a -> b) -> Action m s' a -> Action m s' b
Functor, Functor (Action m s')
a -> Action m s' a
Functor (Action m s')
-> (forall a. a -> Action m s' a)
-> (forall a b.
    Action m s' (a -> b) -> Action m s' a -> Action m s' b)
-> (forall a b c.
    (a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c)
-> (forall a b. Action m s' a -> Action m s' b -> Action m s' b)
-> (forall a b. Action m s' a -> Action m s' b -> Action m s' a)
-> Applicative (Action m s')
Action m s' a -> Action m s' b -> Action m s' b
Action m s' a -> Action m s' b -> Action m s' a
Action m s' (a -> b) -> Action m s' a -> Action m s' b
(a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c
forall a. a -> Action m s' a
forall a b. Action m s' a -> Action m s' b -> Action m s' a
forall a b. Action m s' a -> Action m s' b -> Action m s' b
forall a b. Action m s' (a -> b) -> Action m s' a -> Action m s' b
forall a b c.
(a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) k (s' :: k).
Applicative m =>
Functor (Action m s')
forall (m :: * -> *) k (s' :: k) a.
Applicative m =>
a -> Action m s' a
forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' a -> Action m s' b -> Action m s' a
forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' a -> Action m s' b -> Action m s' b
forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' (a -> b) -> Action m s' a -> Action m s' b
forall (m :: * -> *) k (s' :: k) a b c.
Applicative m =>
(a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c
<* :: Action m s' a -> Action m s' b -> Action m s' a
$c<* :: forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' a -> Action m s' b -> Action m s' a
*> :: Action m s' a -> Action m s' b -> Action m s' b
$c*> :: forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' a -> Action m s' b -> Action m s' b
liftA2 :: (a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c
$cliftA2 :: forall (m :: * -> *) k (s' :: k) a b c.
Applicative m =>
(a -> b -> c) -> Action m s' a -> Action m s' b -> Action m s' c
<*> :: Action m s' (a -> b) -> Action m s' a -> Action m s' b
$c<*> :: forall (m :: * -> *) k (s' :: k) a b.
Applicative m =>
Action m s' (a -> b) -> Action m s' a -> Action m s' b
pure :: a -> Action m s' a
$cpure :: forall (m :: * -> *) k (s' :: k) a.
Applicative m =>
a -> Action m s' a
$cp1Applicative :: forall (m :: * -> *) k (s' :: k).
Applicative m =>
Functor (Action m s')
Applicative, Applicative (Action m s')
a -> Action m s' a
Applicative (Action m s')
-> (forall a b.
    Action m s' a -> (a -> Action m s' b) -> Action m s' b)
-> (forall a b. Action m s' a -> Action m s' b -> Action m s' b)
-> (forall a. a -> Action m s' a)
-> Monad (Action m s')
Action m s' a -> (a -> Action m s' b) -> Action m s' b
Action m s' a -> Action m s' b -> Action m s' b
forall a. a -> Action m s' a
forall a b. Action m s' a -> Action m s' b -> Action m s' b
forall a b. Action m s' a -> (a -> Action m s' b) -> Action m s' b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) k (s' :: k).
Monad m =>
Applicative (Action m s')
forall (m :: * -> *) k (s' :: k) a. Monad m => a -> Action m s' a
forall (m :: * -> *) k (s' :: k) a b.
Monad m =>
Action m s' a -> Action m s' b -> Action m s' b
forall (m :: * -> *) k (s' :: k) a b.
Monad m =>
Action m s' a -> (a -> Action m s' b) -> Action m s' b
return :: a -> Action m s' a
$creturn :: forall (m :: * -> *) k (s' :: k) a. Monad m => a -> Action m s' a
>> :: Action m s' a -> Action m s' b -> Action m s' b
$c>> :: forall (m :: * -> *) k (s' :: k) a b.
Monad m =>
Action m s' a -> Action m s' b -> Action m s' b
>>= :: Action m s' a -> (a -> Action m s' b) -> Action m s' b
$c>>= :: forall (m :: * -> *) k (s' :: k) a b.
Monad m =>
Action m s' a -> (a -> Action m s' b) -> Action m s' b
$cp1Monad :: forall (m :: * -> *) k (s' :: k).
Monad m =>
Applicative (Action m s')
Monad)


------------------------------------------------------------------------------
-- | Given a reifiable mtl Error dictionary,
-- we can make an instance of @MonadError@ for the action
-- wrapped in @Action@.
instance ( Monad m
         , Reifies s' (CatchDict m)
         ) => C.MonadThrow (Action m s') where
  throwM :: e -> Action m s' a
throwM e
e = m a -> Action m s' a
forall k k (m :: k -> *) (s' :: k) (a :: k). m a -> Action m s' a
Action (m a -> Action m s' a) -> m a -> Action m s' a
forall a b. (a -> b) -> a -> b
$ CatchDict m -> SomeException -> m a
forall k (m :: k -> *).
CatchDict m -> forall (a :: k). SomeException -> m a
throwM_ (Proxy s' -> CatchDict m
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s' -> CatchDict m) -> Proxy s' -> CatchDict m
forall a b. (a -> b) -> a -> b
$ Proxy s'
forall k (t :: k). Proxy t
Proxy @s') (e -> SomeException
forall e. Exception e => e -> SomeException
C.toException e
e)
  {-# INLINEABLE throwM #-}

instance ( Monad m
         , Reifies s' (CatchDict m)
         )  => C.MonadCatch (Action m s') where
  catch :: Action m s' a -> (e -> Action m s' a) -> Action m s' a
catch Action m s' a
x e -> Action m s' a
f =
    let catchF :: m a -> (SomeException -> m a) -> m a
catchF = CatchDict m -> forall a. m a -> (SomeException -> m a) -> m a
forall k (m :: k -> *).
CatchDict m
-> forall (a :: k). m a -> (SomeException -> m a) -> m a
catch_ (Proxy s' -> CatchDict m
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s' -> CatchDict m) -> Proxy s' -> CatchDict m
forall a b. (a -> b) -> a -> b
$ Proxy s'
forall k (t :: k). Proxy t
Proxy @s')
    in m a -> Action m s' a
forall k k (m :: k -> *) (s' :: k) (a :: k). m a -> Action m s' a
Action (m a -> Action m s' a) -> m a -> Action m s' a
forall a b. (a -> b) -> a -> b
$ (Action m s' a -> m a
forall k (m :: k -> *) k (s' :: k) (a :: k). Action m s' a -> m a
action Action m s' a
x) m a -> (SomeException -> m a) -> m a
`catchF` \SomeException
e -> case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
C.fromException SomeException
e of
      Just e
e' -> Action m s' a -> m a
forall k (m :: k -> *) k (s' :: k) (a :: k). Action m s' a -> m a
action (Action m s' a -> m a) -> Action m s' a -> m a
forall a b. (a -> b) -> a -> b
$ e -> Action m s' a
f e
e'
      Maybe e
_ -> CatchDict m -> SomeException -> m a
forall k (m :: k -> *).
CatchDict m -> forall (a :: k). SomeException -> m a
throwM_ (Proxy s' -> CatchDict m
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s' -> CatchDict m) -> Proxy s' -> CatchDict m
forall a b. (a -> b) -> a -> b
$ Proxy s'
forall k (t :: k). Proxy t
Proxy @s') (SomeException -> SomeException
forall e. Exception e => e -> SomeException
C.toException SomeException
e)
  {-# INLINEABLE catch #-}