module Polysemy.Resume.Stop where

import Control.Monad.Trans.Except (throwE)
import Data.Typeable (typeRep)
import Polysemy (Final)
import Polysemy.Error (runError, throw)
import Polysemy.Final (getInitialStateS, interpretFinal, runS, withStrategicToFinal)
import Polysemy.Internal (Sem(Sem))
import Polysemy.Internal.Union (Weaving(Weaving), decomp, weave)
import qualified Text.Show

import Control.Exception (throwIO, try)
import Polysemy.Resume.Data.Stop (Stop(Stop), stop)

hush :: Either e a -> Maybe a
hush :: Either e a -> Maybe a
hush (Right a :: a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
hush (Left _) = Maybe a
forall a. Maybe a
Nothing

-- |Equivalent of 'runError'.
runStop ::
  Sem (Stop e : r) a ->
  Sem r (Either e a)
runStop :: Sem (Stop e : r) a -> Sem r (Either e a)
runStop (Sem m :: forall (m :: * -> *).
Monad m =>
(forall x. Union (Stop e : r) (Sem (Stop e : r)) x -> m x) -> m a
m) =
  (forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m (Either e a))
-> Sem r (Either e a)
forall (r :: EffectRow) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem \ k :: forall x. Union r (Sem r) x -> m x
k ->
    ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m a -> m (Either e a))
-> ExceptT e m a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ (forall x.
 Union (Stop e : r) (Sem (Stop e : r)) x -> ExceptT e m x)
-> ExceptT e m a
forall (m :: * -> *).
Monad m =>
(forall x. Union (Stop e : r) (Sem (Stop e : r)) x -> m x) -> m a
m \ u :: Union (Stop e : r) (Sem (Stop e : r)) x
u ->
      case Union (Stop e : r) (Sem (Stop e : r)) x
-> Either
     (Union r (Sem (Stop e : r)) x)
     (Weaving (Stop e) (Sem (Stop e : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Stop e : r) (Sem (Stop e : r)) x
u of
        Left x :: Union r (Sem (Stop e : r)) x
x ->
          m (Either e x) -> ExceptT e m x
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e x) -> ExceptT e m x)
-> m (Either e x) -> ExceptT e m x
forall a b. (a -> b) -> a -> b
$ Union r (Sem r) (Either e x) -> m (Either e x)
forall x. Union r (Sem r) x -> m x
k (Union r (Sem r) (Either e x) -> m (Either e x))
-> Union r (Sem r) (Either e x) -> m (Either e x)
forall a b. (a -> b) -> a -> b
$ Either e ()
-> (forall x. Either e (Sem (Stop e : r) x) -> Sem r (Either e x))
-> (forall x. Either e x -> Maybe x)
-> Union r (Sem (Stop e : r)) x
-> Union r (Sem r) (Either e x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *) (r :: EffectRow)
       a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave (() -> Either e ()
forall a b. b -> Either a b
Right ()) ((e -> Sem r (Either e x))
-> (Sem (Stop e : r) x -> Sem r (Either e x))
-> Either e (Sem (Stop e : r) x)
-> Sem r (Either e x)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e x -> Sem r (Either e x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e x -> Sem r (Either e x))
-> (e -> Either e x) -> e -> Sem r (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e x
forall a b. a -> Either a b
Left) Sem (Stop e : r) x -> Sem r (Either e x)
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop) forall x. Either e x -> Maybe x
forall e a. Either e a -> Maybe a
hush Union r (Sem (Stop e : r)) x
x
        Right (Weaving (Stop e :: e
e) _ _ _ _) ->
          e -> ExceptT e m x
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
e
{-# INLINE runStop #-}

newtype WrappedExc e =
  WrappedExc { WrappedExc e -> e
unwrapExc :: e }
  deriving (Typeable)

instance Typeable e => Show (WrappedExc e) where
  show :: WrappedExc e -> String
show =
    String -> ShowS
forall a. Monoid a => a -> a -> a
mappend "WrappedExc: " ShowS -> (WrappedExc e -> String) -> WrappedExc e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeRep -> String)
-> (WrappedExc e -> TypeRep) -> WrappedExc e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedExc e -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

instance Typeable e => Exception (WrappedExc e)

runStopAsExcFinal ::
  Typeable e =>
  Member (Final IO) r =>
  Sem (Stop e : r) a ->
  Sem r a
runStopAsExcFinal :: Sem (Stop e : r) a -> Sem r a
runStopAsExcFinal =
  (forall x (rInitial :: EffectRow).
 Stop e (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (Stop e : r) a -> Sem r a
forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal \case
    Stop e ->
      IO (f x) -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedExc e -> IO (f x)
forall e a. Exception e => e -> IO a
throwIO (e -> WrappedExc e
forall e. e -> WrappedExc e
WrappedExc e
e))
{-# INLINE runStopAsExcFinal #-}

-- |Run 'Stop' by throwing exceptions.
stopToIOFinal ::
  Typeable e =>
  Member (Final IO) r =>
  Sem (Stop e : r) a ->
  Sem r (Either e a)
stopToIOFinal :: Sem (Stop e : r) a -> Sem r (Either e a)
stopToIOFinal sem :: Sem (Stop e : r) a
sem =
  Strategic IO (Sem r) (Either e a) -> Sem r (Either e a)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal @IO do
    IO (f a)
m' <- Sem r a -> Sem (WithStrategy IO f (Sem r)) (IO (f a))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS (Sem (Stop e : r) a -> Sem r a
forall e (r :: EffectRow) a.
(Typeable e, Member (Final IO) r) =>
Sem (Stop e : r) a -> Sem r a
runStopAsExcFinal Sem (Stop e : r) a
sem)
    f ()
s <- Sem (WithStrategy IO f (Sem r)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    pure $ (WrappedExc e -> f (Either e a))
-> (f a -> f (Either e a))
-> Either (WrappedExc e) (f a)
-> f (Either e a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Either e a -> f () -> f (Either e a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (Either e a -> f (Either e a))
-> (WrappedExc e -> Either e a) -> WrappedExc e -> f (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left (e -> Either e a)
-> (WrappedExc e -> e) -> WrappedExc e -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedExc e -> e
forall e. WrappedExc e -> e
unwrapExc) ((a -> Either e a) -> f a -> f (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right) (Either (WrappedExc e) (f a) -> f (Either e a))
-> IO (Either (WrappedExc e) (f a)) -> IO (f (Either e a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f a) -> IO (Either (WrappedExc e) (f a))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (f a)
m'
{-# INLINE stopToIOFinal #-}

-- |Stop if the argument is 'Left'.
stopEither ::
  Member (Stop err) r =>
  Either err a ->
  Sem r a
stopEither :: Either err a -> Sem r a
stopEither =
  (err -> Sem r a) -> (a -> Sem r a) -> Either err a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either err -> Sem r a
forall e (r :: EffectRow) a.
MemberWithError (Stop e) r =>
e -> Sem r a
stop a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- |Convert a program using regular 'Error's to one using 'Stop'.
stopOnError ::
  Member (Stop err) r =>
  Sem (Error err : r) a ->
  Sem r a
stopOnError :: Sem (Error err : r) a -> Sem r a
stopOnError =
  Either err a -> Sem r a
forall err (r :: EffectRow) a.
Member (Stop err) r =>
Either err a -> Sem r a
stopEither (Either err a -> Sem r a)
-> (Sem (Error err : r) a -> Sem r (Either err a))
-> Sem (Error err : r) a
-> Sem r a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Error err : r) a -> Sem r (Either err a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
{-# INLINE stopOnError #-}

-- |Convert a program using 'Stop' to one using 'Error'.
stopToError ::
  Member (Error err) r =>
  Sem (Stop err : r) a ->
  Sem r a
stopToError :: Sem (Stop err : r) a -> Sem r a
stopToError =
  (err -> Sem r a) -> (a -> Sem r a) -> Either err a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either err -> Sem r a
forall e (r :: EffectRow) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> Sem r a)
-> (Sem (Stop err : r) a -> Sem r (Either err a))
-> Sem (Stop err : r) a
-> Sem r a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Stop err : r) a -> Sem r (Either err a)
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop
{-# INLINE stopToError #-}

-- |Convert a program using 'Stop' to one using 'Error'.
stopToErrorIO ::
  Typeable err =>
  Members [Error err, Final IO] r =>
  Sem (Stop err : r) a ->
  Sem r a
stopToErrorIO :: Sem (Stop err : r) a -> Sem r a
stopToErrorIO =
  (err -> Sem r a) -> (a -> Sem r a) -> Either err a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either err -> Sem r a
forall e (r :: EffectRow) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> Sem r a)
-> (Sem (Stop err : r) a -> Sem r (Either err a))
-> Sem (Stop err : r) a
-> Sem r a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Stop err : r) a -> Sem r (Either err a)
forall e (r :: EffectRow) a.
(Typeable e, Member (Final IO) r) =>
Sem (Stop e : r) a -> Sem r (Either e a)
stopToIOFinal
{-# INLINE stopToErrorIO #-}