module Polysemy.Resume.Stop where

import Control.Exception (throwIO, try)
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), send, usingSem)
import Polysemy.Internal.Union (Weaving(Weaving), decomp, hoist, weave)
import qualified Text.Show

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 -> Maybe a
forall a. a -> Maybe a
Just a
a
hush (Left e
_) = 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 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 \ 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 \ 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 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) f ()
_ forall x. f (Sem rInitial x) -> Sem (Stop e : r) (f x)
_ f a -> x
_ forall x. f x -> Maybe x
_) ->
          e -> ExceptT e m x
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
e
{-# INLINE runStop #-}

newtype StopExc e =
  StopExc { StopExc e -> e
unStopExc :: e }
  deriving (Typeable)

instance {-# overlappable #-} Typeable e => Show (StopExc e) where
  show :: StopExc e -> String
show =
    String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"StopExc: " ShowS -> (StopExc e -> String) -> StopExc 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)
-> (StopExc e -> TypeRep) -> StopExc e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StopExc e -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

instance Show (StopExc Text) where
  show :: StopExc Text -> String
show (StopExc Text
e) =
    String
"StopExc " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
e

instance {-# overlappable #-} Typeable e => Exception (StopExc e)

instance Exception (StopExc Text)

runStopAsExcFinal ::
  Exception (StopExc 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 (StopExc e -> IO (f x)
forall e a. Exception e => e -> IO a
throwIO (e -> StopExc e
forall e. e -> StopExc e
StopExc e
e))
{-# INLINE runStopAsExcFinal #-}

-- |Run 'Stop' by throwing exceptions.
stopToIOFinal ::
  Exception (StopExc 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 (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.
(Exception (StopExc 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 $ (StopExc e -> f (Either e a))
-> (f a -> f (Either e a))
-> Either (StopExc 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))
-> (StopExc e -> Either e a) -> StopExc 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) -> (StopExc e -> e) -> StopExc e -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StopExc e -> e
forall e. StopExc e -> e
unStopExc) ((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 (StopExc e) (f a) -> f (Either e a))
-> IO (Either (StopExc 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 (StopExc 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', transforming the error with @f@.
stopEitherWith ::
  Member (Stop err') r =>
  (err -> err') ->
  Either err a ->
  Sem r a
stopEitherWith :: (err -> err') -> Either err a -> Sem r a
stopEitherWith err -> err'
f =
  (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 (err' -> Sem r a) -> (err -> err') -> err -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> err'
f) a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE stopEitherWith #-}

-- |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 -> err) -> Either err a -> Sem r a
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith err -> err
forall a. a -> a
id
{-# INLINE stopEither #-}

-- |Stop with the supplied error if the argument is 'Nothing'.
stopNote ::
  Member (Stop err) r =>
  err ->
  Maybe a ->
  Sem r a
stopNote :: err -> Maybe a -> Sem r a
stopNote err
err =
  Sem r a -> (a -> Sem r a) -> Maybe a -> Sem r a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (err -> Sem r a
forall e (r :: EffectRow) a.
MemberWithError (Stop e) r =>
e -> Sem r a
stop err
err) a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE stopNote #-}

-- |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 regular 'Error's to one using 'Stop'.
stopOnErrorWith ::
  Member (Stop err') r =>
  (err -> err') ->
  Sem (Error err : r) a ->
  Sem r a
stopOnErrorWith :: (err -> err') -> Sem (Error err : r) a -> Sem r a
stopOnErrorWith err -> err'
f =
  (err -> err') -> Either err a -> Sem r a
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith err -> err'
f (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 stopOnErrorWith #-}

-- |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 ::
  Exception (StopExc 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.
(Exception (StopExc e), Member (Final IO) r) =>
Sem (Stop e : r) a -> Sem r (Either e a)
stopToIOFinal
{-# INLINE stopToErrorIO #-}

-- |Map over the error type in a 'Stop'.
mapStop ::
  ∀ e e' r a .
  Member (Stop e') r =>
  (e -> e') ->
  Sem (Stop e : r) a ->
  Sem r a
mapStop :: (e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop e -> e'
f (Sem 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 a)
-> Sem r a
forall (r :: EffectRow) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem \ forall x. Union r (Sem r) x -> m x
k -> (forall x. Union (Stop e : r) (Sem (Stop e : r)) x -> m x) -> m a
forall (m :: * -> *).
Monad m =>
(forall x. Union (Stop e : r) (Sem (Stop e : r)) x -> m x) -> m a
m \ 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 Union r (Sem (Stop e : r)) x
x ->
        Union r (Sem r) x -> m x
forall x. Union r (Sem r) x -> m x
k ((forall x. Sem (Stop e : r) x -> Sem r x)
-> Union r (Sem (Stop e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist ((e -> e') -> Sem (Stop e : r) x -> Sem r x
forall e e' (r :: EffectRow) a.
Member (Stop e') r =>
(e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop e -> e'
f) Union r (Sem (Stop e : r)) x
x)
      Right (Weaving (Stop e
e) f ()
_ forall x. f (Sem rInitial x) -> Sem (Stop e : r) (f x)
_ f a -> x
_ forall x. f x -> Maybe x
_) ->
        (forall x. Union r (Sem r) x -> m x) -> Sem r x -> m x
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem forall x. Union r (Sem r) x -> m x
k (Stop e' (Sem r) x -> Sem r x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member e r =>
e (Sem r) a -> Sem r a
send (Stop e' (Sem r) x -> Sem r x) -> Stop e' (Sem r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ e' -> Stop e' (Sem r) x
forall e (m :: * -> *) a. e -> Stop e m a
Stop (e -> e'
f e
e))
{-# INLINE mapStop #-}

-- |Convert the error type in a 'Stop' to 'Text'.
showStop ::
  ∀ e r a .
  Show e =>
  Member (Stop Text) r =>
  Sem (Stop e : r) a ->
  Sem r a
showStop :: Sem (Stop e : r) a -> Sem r a
showStop =
  (e -> Text) -> Sem (Stop e : r) a -> Sem r a
forall e e' (r :: EffectRow) a.
Member (Stop e') r =>
(e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop @e @Text e -> Text
forall b a. (Show a, IsString b) => a -> b
show
{-# INLINE showStop #-}