-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2023 Sayo Koyoneda
License     :  MPL-2.0 (see the LICENSE file)
Maintainer  :  ymdfield@outlook.jp

Interpreters for the [Except]("Data.Effect.Except") effects.
-}
module Control.Monad.Hefty.Except (
    module Control.Monad.Hefty.Except,
    module Data.Effect.Except,
)
where

import Control.Exception (Exception)
import Control.Monad.Hefty (
    Eff,
    Interpreter,
    interposeWith,
    interpret,
    interpretBy,
    interpretH,
    (&),
    type (<<|),
    type (<|),
    type (~>),
    type (~~>),
 )
import Data.Effect.Except
import Data.Effect.Unlift (UnliftIO)
import UnliftIO (throwIO)
import UnliftIO qualified as IO

-- | Interpret the t'Throw'/t'Catch' effects.
runExcept :: Eff '[Catch e] (Throw e ': r) a -> Eff '[] r (Either e a)
runExcept :: forall e (r :: [* -> *]) a.
Eff '[Catch e] (Throw e : r) a -> Eff '[] r (Either e a)
runExcept = Eff '[] (Throw e : r) a -> Eff '[] r (Either e a)
forall e (r :: [* -> *]) a.
Eff '[] (Throw e : r) a -> Eff '[] r (Either e a)
runThrow (Eff '[] (Throw e : r) a -> Eff '[] r (Either e a))
-> (Eff '[Catch e] (Throw e : r) a -> Eff '[] (Throw e : r) a)
-> Eff '[Catch e] (Throw e : r) a
-> Eff '[] r (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[Catch e] (Throw e : r) a -> Eff '[] (Throw e : r) a
Eff '[Catch e] (Throw e : r) ~> Eff '[] (Throw e : r)
forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Eff '[Catch e] ef ~> Eff '[] ef
runCatch

-- | Interpret the t'Throw' effect.
runThrow :: Eff '[] (Throw e ': r) a -> Eff '[] r (Either e a)
runThrow :: forall e (r :: [* -> *]) a.
Eff '[] (Throw e : r) a -> Eff '[] r (Either e a)
runThrow = (a -> Eff '[] r (Either e a))
-> Interpreter (Throw e) (Eff '[] r) (Either e a)
-> Eff '[] (Throw e : r) a
-> Eff '[] r (Either e a)
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy (Either e a -> Eff '[] r (Either e a)
forall a. a -> Eff '[] r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> Eff '[] r (Either e a))
-> (a -> Either e a) -> a -> Eff '[] r (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right) Throw e x
-> (x -> Eff '[] r (Either e a)) -> Eff '[] r (Either e a)
Interpreter (Throw e) (Eff '[] r) (Either e a)
forall e (r :: [* -> *]) a x.
Throw e x
-> (x -> Eff '[] r (Either e a)) -> Eff '[] r (Either e a)
handleThrow

-- | Interpret the t'Catch' effect.
runCatch :: (Throw e <| ef) => Eff '[Catch e] ef ~> Eff '[] ef
runCatch :: forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Eff '[Catch e] ef ~> Eff '[] ef
runCatch = (Catch e ~~> Eff '[] ef) -> Eff '[Catch e] ef ~> Eff '[] ef
forall (e :: (* -> *) -> * -> *) (eh :: [(* -> *) -> * -> *])
       (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH Catch e (Eff '[] ef) x -> Eff '[] ef x
Catch e ~~> Eff '[] ef
forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Catch e ~~> Eff '[] ef
elabCatch

-- | A handler function for the t'Throw' effect.
handleThrow :: Interpreter (Throw e) (Eff '[] r) (Either e a)
handleThrow :: forall e (r :: [* -> *]) a x.
Throw e x
-> (x -> Eff '[] r (Either e a)) -> Eff '[] r (Either e a)
handleThrow (Throw e
e) x -> Eff '[] r (Either e a)
_ = Either e a -> Eff '[] r (Either e a)
forall a. a -> Eff '[] r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> Eff '[] r (Either e a))
-> Either e a -> Eff '[] r (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left e
e
{-# INLINE handleThrow #-}

-- | A elaborator function for the t'Catch' effect.
elabCatch :: (Throw e <| ef) => Catch e ~~> Eff '[] ef
elabCatch :: forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Catch e ~~> Eff '[] ef
elabCatch (Catch Eff '[] ef x
action e -> Eff '[] ef x
hdl) = Eff '[] ef x
action Eff '[] ef x -> (Eff '[] ef x -> Eff '[] ef x) -> Eff '[] ef x
forall a b. a -> (a -> b) -> b
& Interpreter (Throw e) (Eff '[] ef) x
-> Eff '[] ef x -> Eff '[] ef x
forall (e :: * -> *) (ef :: [* -> *]) a.
(e <| ef) =>
Interpreter e (Eff '[] ef) a -> Eff '[] ef a -> Eff '[] ef a
interposeWith \(Throw e
e) x -> Eff '[] ef x
_ -> e -> Eff '[] ef x
hdl e
e
{-# INLINE elabCatch #-}

-- | Interpret the t'Throw' effect based on an IO-fused semantics using IO-level exceptions.
runThrowIO
    :: forall e eh ef
     . (IO <| ef, Exception e)
    => Eff eh (Throw e ': ef) ~> Eff eh ef
runThrowIO :: forall e (eh :: [(* -> *) -> * -> *]) (ef :: [* -> *]).
(IO <| ef, Exception e) =>
Eff eh (Throw e : ef) ~> Eff eh ef
runThrowIO = (Throw e ~> Eff eh ef) -> Eff eh (Throw e : ef) ~> Eff eh ef
forall (e :: * -> *) (ef :: [* -> *]) (eh :: [(* -> *) -> * -> *]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \(Throw e
e) -> e -> Eff eh ef x
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO e
e

-- | Interpret the t'Catch' effect based on an IO-fused semantics using IO-level exceptions.
runCatchIO
    :: forall e eh ef
     . (UnliftIO <<| eh, IO <| ef, Exception e)
    => Eff (Catch e ': eh) ef ~> Eff eh ef
runCatchIO :: forall e (eh :: [(* -> *) -> * -> *]) (ef :: [* -> *]).
(UnliftIO <<| eh, IO <| ef, Exception e) =>
Eff (Catch e : eh) ef ~> Eff eh ef
runCatchIO = (Catch e ~~> Eff eh ef) -> Eff (Catch e : eh) ef ~> Eff eh ef
forall (e :: (* -> *) -> * -> *) (eh :: [(* -> *) -> * -> *])
       (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH \(Catch Eff eh ef x
action e -> Eff eh ef x
hdl) -> Eff eh ef x -> (e -> Eff eh ef x) -> Eff eh ef x
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
IO.catch Eff eh ef x
action e -> Eff eh ef x
hdl