-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

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

Interpreters for the t'Data.Effect.Except.Throw' / t'Data.Effect.Except.Catch' effects.
-}
module Control.Monad.Hefty.Except where

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

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

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

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

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 #-}

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 #-}

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

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

prog :: Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
prog :: Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
prog = Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
forall a. HasCallStack => a
undefined

prog' :: Eff '[] [Throw String, Throw Int] ()
prog' :: Eff '[] '[Throw String, Throw Int] ()
prog' = (UnionH '[Catch String, Catch Int]
 ~~> Eff '[] '[Throw String, Throw Int])
-> Eff
     '[UnionH '[Catch String, Catch Int]] '[Throw String, Throw Int]
   ~> Eff '[] '[Throw String, Throw Int]
forall (e :: (* -> *) -> * -> *) (eh :: [(* -> *) -> * -> *])
       (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH (forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Catch e ~~> Eff '[] ef
elabCatch @String (Catch String (Eff '[] '[Throw String, Throw Int]) x
 -> Eff '[] '[Throw String, Throw Int] x)
-> (UnionH '[Catch Int] (Eff '[] '[Throw String, Throw Int]) x
    -> Eff '[] '[Throw String, Throw Int] x)
-> UnionH
     '[Catch String, Catch Int] (Eff '[] '[Throw String, Throw Int]) x
-> Eff '[] '[Throw String, Throw Int] x
forall (e :: (* -> *) -> * -> *) (f :: * -> *) a r
       (es :: [(* -> *) -> * -> *]).
HFunctor e =>
(e f a -> r) -> (UnionH es f a -> r) -> UnionH (e : es) f a -> r
!!+ forall e (ef :: [* -> *]).
(Throw e <| ef) =>
Catch e ~~> Eff '[] ef
elabCatch @Int (Catch Int (Eff '[] '[Throw String, Throw Int]) x
 -> Eff '[] '[Throw String, Throw Int] x)
-> (UnionH '[] (Eff '[] '[Throw String, Throw Int]) x
    -> Eff '[] '[Throw String, Throw Int] x)
-> UnionH '[Catch Int] (Eff '[] '[Throw String, Throw Int]) x
-> Eff '[] '[Throw String, Throw Int] x
forall (e :: (* -> *) -> * -> *) (f :: * -> *) a r
       (es :: [(* -> *) -> * -> *]).
HFunctor e =>
(e f a -> r) -> (UnionH es f a -> r) -> UnionH (e : es) f a -> r
!!+ UnionH '[] (Eff '[] '[Throw String, Throw Int]) x
-> Eff '[] '[Throw String, Throw Int] x
forall (f :: * -> *) a r. UnionH '[] f a -> r
nilH) (Eff
   '[UnionH '[Catch String, Catch Int]] '[Throw String, Throw Int] ()
 -> Eff '[] '[Throw String, Throw Int] ())
-> (Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
    -> Eff
         '[UnionH '[Catch String, Catch Int]] '[Throw String, Throw Int] ())
-> Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
-> Eff '[] '[Throw String, Throw Int] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
-> Eff
     '[UnionH '[Catch String, Catch Int]] '[Throw String, Throw Int] ()
forall (eh :: [(* -> *) -> * -> *]) (ef :: [* -> *]) x.
Eff eh ef x -> Eff '[UnionH eh] ef x
bundleAllH (Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
 -> Eff '[] '[Throw String, Throw Int] ())
-> Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
-> Eff '[] '[Throw String, Throw Int] ()
forall a b. (a -> b) -> a -> b
$ Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()
prog