{-# LANGUAGE Arrows     #-}
{-# LANGUAGE CPP        #-}
{-# LANGUAGE Rank2Types #-}
-- |
-- Copyright  : (c) Ivan Perez and Manuel Baerenz, 2016
-- License    : BSD3
-- Maintainer : ivan.perez@keera.co.uk
--
-- 'MSF's in the 'ExceptT' monad are monadic stream functions that can throw
-- exceptions, i.e. return an exception value instead of a continuation. This
-- module gives ways to throw exceptions in various ways, and to handle them
-- through a monadic interface.
module Control.Monad.Trans.MSF.Except
    ( module Control.Monad.Trans.MSF.Except
    , module Control.Monad.Trans.Except
    )
  where

-- External imports
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative        (Applicative (..), (<$>))
#endif

import           Control.Arrow              (arr, returnA, (<<<), (>>>))
import qualified Control.Category           as Category
import           Control.Monad              (ap, liftM)
import           Control.Monad.Trans.Class  (lift)
import           Control.Monad.Trans.Except hiding (liftCallCC, liftListen,
                                             liftPass)
import           Control.Monad.Trans.Maybe  (MaybeT, runMaybeT)
import           Data.Void                  (Void)

-- Internal imports
import Data.MonadicStreamFunction              (arrM, constM, count, feedback,
                                                liftTransS, mapMaybeS, morphS,
                                                reactimate)
import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))

-- External, necessary for older base versions
#if __GLASGOW_HASKELL__ < 802
fromLeft  :: a -> Either a b -> a
fromLeft  _ (Left  a) = a
fromLeft  a (Right _) = a
fromRight :: b -> Either a b -> b
fromRight _ (Right b) = b
fromRight b (Left  _) = b
#else
import           Data.Either                (fromLeft, fromRight)
#endif

-- * Throwing exceptions

-- | Throw the exception 'e' whenever the function evaluates to 'True'.
throwOnCond :: Monad m => (a -> Bool) -> e -> MSF (ExceptT e m) a a
throwOnCond :: (a -> Bool) -> e -> MSF (ExceptT e m) a a
throwOnCond a -> Bool
cond e
e = proc a
a -> if a -> Bool
cond a
a
  then MSF (ExceptT e m) e a
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS  -< e
e
  else MSF (ExceptT e m) a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< a
a

-- | Throws the exception when the input is 'True'. Variant of 'throwOnCond'
-- for Kleisli arrows.
throwOnCondM :: Monad m => (a -> m Bool) -> e -> MSF (ExceptT e m) a a
throwOnCondM :: (a -> m Bool) -> e -> MSF (ExceptT e m) a a
throwOnCondM a -> m Bool
cond e
e = proc a
a -> do
  Bool
b <- (a -> ExceptT e m Bool) -> MSF (ExceptT e m) a Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (m Bool -> ExceptT e m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT e m Bool)
-> (a -> m Bool) -> a -> ExceptT e m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
cond) -< a
a
  if Bool
b
    then MSF (ExceptT e m) e a
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS  -< e
e
    else MSF (ExceptT e m) a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< a
a

-- | Throw the exception when the input is 'True'.
throwOn :: Monad m => e -> MSF (ExceptT e m) Bool ()
throwOn :: e -> MSF (ExceptT e m) Bool ()
throwOn e
e = proc Bool
b -> MSF (ExceptT e m) (Bool, e) ()
forall (m :: * -> *) e. Monad m => MSF (ExceptT e m) (Bool, e) ()
throwOn' -< (Bool
b, e
e)

-- | Variant of 'throwOn', where the exception may change every tick.
throwOn' :: Monad m => MSF (ExceptT e m) (Bool, e) ()
throwOn' :: MSF (ExceptT e m) (Bool, e) ()
throwOn' = proc (Bool
b, e
e) -> if Bool
b
  then MSF (ExceptT e m) e ()
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS  -< e
e
  else MSF (ExceptT e m) () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

-- | When the input is @Just e@, throw the exception @e@. (Does not output any
-- actual data.)
throwMaybe :: Monad m => MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe :: MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe = MSF (ExceptT e m) e a -> MSF (ExceptT e m) (Maybe e) (Maybe a)
forall (m :: * -> *) a b.
Monad m =>
MSF m a b -> MSF m (Maybe a) (Maybe b)
mapMaybeS MSF (ExceptT e m) e a
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS

-- | Immediately throw the incoming exception.
throwS :: Monad m => MSF (ExceptT e m) e a
throwS :: MSF (ExceptT e m) e a
throwS = (e -> ExceptT e m a) -> MSF (ExceptT e m) e a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM e -> ExceptT e m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

-- | Immediately throw the given exception.
throw :: Monad m => e -> MSF (ExceptT e m) a b
throw :: e -> MSF (ExceptT e m) a b
throw = ExceptT e m b -> MSF (ExceptT e m) a b
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (ExceptT e m b -> MSF (ExceptT e m) a b)
-> (e -> ExceptT e m b) -> e -> MSF (ExceptT e m) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ExceptT e m b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

-- | Do not throw an exception.
pass :: Monad m => MSF (ExceptT e m) a a
pass :: MSF (ExceptT e m) a a
pass = MSF (ExceptT e m) a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Category.id

-- | Converts an 'MSF' in 'MaybeT' to an 'MSF' in 'ExceptT'. Whenever
-- 'Nothing' is thrown, throw @()@ instead.
maybeToExceptS :: (Functor m, Monad m)
               => MSF (MaybeT m) a b -> MSF (ExceptT () m) a b
maybeToExceptS :: MSF (MaybeT m) a b -> MSF (ExceptT () m) a b
maybeToExceptS = (forall c. MaybeT m c -> ExceptT () m c)
-> MSF (MaybeT m) a b -> MSF (ExceptT () m) a b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS (m (Either () c) -> ExceptT () m c
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either () c) -> ExceptT () m c)
-> (MaybeT m c -> m (Either () c)) -> MaybeT m c -> ExceptT () m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either () c -> (c -> Either () c) -> Maybe c -> Either () c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either () c
forall a b. a -> Either a b
Left ()) c -> Either () c
forall a b. b -> Either a b
Right (Maybe c -> Either () c) -> m (Maybe c) -> m (Either () c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Maybe c) -> m (Either () c))
-> (MaybeT m c -> m (Maybe c)) -> MaybeT m c -> m (Either () c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m c -> m (Maybe c)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT)

-- * Catching exceptions

-- | Catch an exception in an 'MSF'. As soon as an exception occurs, the
-- current continuation is replaced by a new 'MSF', the exception handler,
-- based on the exception value. For exception catching where the handler can
-- throw further exceptions, see 'MSFExcept' further below.
catchS :: Monad m => MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b
catchS :: MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b
catchS MSF (ExceptT e m) a b
msf e -> MSF m a b
f = MSFExcept m a b Void -> MSF m a b
forall (m :: * -> *) a b.
Monad m =>
MSFExcept m a b Void -> MSF m a b
safely (MSFExcept m a b Void -> MSF m a b)
-> MSFExcept m a b Void -> MSF m a b
forall a b. (a -> b) -> a -> b
$ do
  e
e <- MSF (ExceptT e m) a b -> MSFExcept m a b e
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try MSF (ExceptT e m) a b
msf
  MSF m a b -> MSFExcept m a b Void
forall (m :: * -> *) a b e.
Monad m =>
MSF m a b -> MSFExcept m a b e
safe (MSF m a b -> MSFExcept m a b Void)
-> MSF m a b -> MSFExcept m a b Void
forall a b. (a -> b) -> a -> b
$ e -> MSF m a b
f e
e

-- | Similar to Yampa's delayed switching. Loses a @b@ in case of an exception.
untilE :: Monad m
       => MSF m a b
       -> MSF m b (Maybe e)
       -> MSF (ExceptT e m) a b
untilE :: MSF m a b -> MSF m b (Maybe e) -> MSF (ExceptT e m) a b
untilE MSF m a b
msf MSF m b (Maybe e)
msfe = proc a
a -> do
  b
b  <- MSF m a b -> MSF (ExceptT e m) a b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS MSF m a b
msf  -< a
a
  Maybe e
me <- MSF m b (Maybe e) -> MSF (ExceptT e m) b (Maybe e)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS MSF m b (Maybe e)
msfe -< b
b
  MSF (ExceptT e m) (ExceptT e m b) b
forall (m :: * -> *) e a.
Monad m =>
MSF (ExceptT e m) (ExceptT e m a) a
inExceptT -< m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> m (Either e b) -> ExceptT e m b
forall a b. (a -> b) -> a -> b
$ Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ Either e b -> (e -> Either e b) -> Maybe e -> Either e b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> Either e b
forall a b. b -> Either a b
Right b
b) e -> Either e b
forall a b. a -> Either a b
Left Maybe e
me

-- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs.
-- If an exception occurs, the current 'MSF' continuation is tested again on
-- the next input.
exceptS :: (Functor m, Monad m) => MSF (ExceptT e m) a b -> MSF m a (Either e b)
exceptS :: MSF (ExceptT e m) a b -> MSF m a (Either e b)
exceptS = (a -> ExceptT e m a)
-> (forall c. a -> ExceptT e m (b, c) -> m (Either e b, Maybe c))
-> MSF (ExceptT e m) a b
-> MSF m a (Either e b)
forall (m1 :: * -> *) (m2 :: * -> *) a2 a1 b1 b2.
(Monad m1, Monad m2) =>
(a2 -> m1 a1)
-> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))
-> MSF m1 a1 b1
-> MSF m2 a2 b2
transG a -> ExceptT e m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall c. a -> ExceptT e m (b, c) -> m (Either e b, Maybe c))
 -> MSF (ExceptT e m) a b -> MSF m a (Either e b))
-> (forall c. a -> ExceptT e m (b, c) -> m (Either e b, Maybe c))
-> MSF (ExceptT e m) a b
-> MSF m a (Either e b)
forall a b. (a -> b) -> a -> b
$ (ExceptT e m (b, c) -> m (Either e b, Maybe c))
-> a -> ExceptT e m (b, c) -> m (Either e b, Maybe c)
forall a b. a -> b -> a
const ((ExceptT e m (b, c) -> m (Either e b, Maybe c))
 -> a -> ExceptT e m (b, c) -> m (Either e b, Maybe c))
-> (ExceptT e m (b, c) -> m (Either e b, Maybe c))
-> a
-> ExceptT e m (b, c)
-> m (Either e b, Maybe c)
forall a b. (a -> b) -> a -> b
$ (Either e (b, c) -> (Either e b, Maybe c))
-> m (Either e (b, c)) -> m (Either e b, Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e (b, c) -> (Either e b, Maybe c)
forall a b a. Either a (b, a) -> (Either a b, Maybe a)
f (m (Either e (b, c)) -> m (Either e b, Maybe c))
-> (ExceptT e m (b, c) -> m (Either e (b, c)))
-> ExceptT e m (b, c)
-> m (Either e b, Maybe c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m (b, c) -> m (Either e (b, c))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
  where
    f :: Either a (b, a) -> (Either a b, Maybe a)
f (Left a
e)       = (a -> Either a b
forall a b. a -> Either a b
Left a
e , Maybe a
forall a. Maybe a
Nothing)
    f (Right (b
b, a
c)) = (b -> Either a b
forall a b. b -> Either a b
Right b
b, a -> Maybe a
forall a. a -> Maybe a
Just a
c )

-- | Embed an 'ExceptT' value inside the 'MSF'. Whenever the input value is an
-- ordinary value, it is passed on. If it is an exception, it is raised.
inExceptT :: Monad m => MSF (ExceptT e m) (ExceptT e m a) a
inExceptT :: MSF (ExceptT e m) (ExceptT e m a) a
inExceptT = (ExceptT e m a -> ExceptT e m a)
-> MSF (ExceptT e m) (ExceptT e m a) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM ExceptT e m a -> ExceptT e m a
forall a. a -> a
id

-- | In case an exception occurs in the first argument, replace the exception
-- by the second component of the tuple.
tagged :: Monad m => MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) (a, e2) b
tagged :: MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) (a, e2) b
tagged MSF (ExceptT e1 m) a b
msf = MSFExcept m (a, e2) b e2 -> MSF (ExceptT e2 m) (a, e2) b
forall (m :: * -> *) a b e.
MSFExcept m a b e -> MSF (ExceptT e m) a b
runMSFExcept (MSFExcept m (a, e2) b e2 -> MSF (ExceptT e2 m) (a, e2) b)
-> MSFExcept m (a, e2) b e2 -> MSF (ExceptT e2 m) (a, e2) b
forall a b. (a -> b) -> a -> b
$ do
  e1
_       <- MSF (ExceptT e1 m) (a, e2) b -> MSFExcept m (a, e2) b e1
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try (MSF (ExceptT e1 m) (a, e2) b -> MSFExcept m (a, e2) b e1)
-> MSF (ExceptT e1 m) (a, e2) b -> MSFExcept m (a, e2) b e1
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT e1 m) a b
msf MSF (ExceptT e1 m) a b
-> MSF (ExceptT e1 m) (a, e2) a -> MSF (ExceptT e1 m) (a, e2) b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((a, e2) -> a) -> MSF (ExceptT e1 m) (a, e2) a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a, e2) -> a
forall a b. (a, b) -> a
fst
  (a
_, e2
e2) <- MSFExcept m (a, e2) b (a, e2)
forall (m :: * -> *) e b. Monad m => MSFExcept m e b e
currentInput
  e2 -> MSFExcept m (a, e2) b e2
forall (m :: * -> *) a. Monad m => a -> m a
return e2
e2

-- * Monad interface for Exception MSFs

-- | 'MSF's with an 'ExceptT' transformer layer are in fact monads /in the
-- exception type/.
--
--   * 'return' corresponds to throwing an exception immediately.
--   * '>>=' is exception handling: The first value throws an exception, while
--     the Kleisli arrow handles the exception and produces a new signal
--     function, which can throw exceptions in a different type.
--   * @m@: The monad that the 'MSF' may take side effects in.
--   * @a@: The input type
--   * @b@: The output type
--   * @e@: The type of exceptions that can be thrown
newtype MSFExcept m a b e = MSFExcept { MSFExcept m a b e -> MSF (ExceptT e m) a b
runMSFExcept :: MSF (ExceptT e m) a b }

-- | Execute an 'MSF' in 'ExceptT' until it raises an exception.
--
-- An alias for the 'MSFExcept' constructor, used to enter the 'MSFExcept'
-- monad context.
try :: MSF (ExceptT e m) a b -> MSFExcept m a b e
try :: MSF (ExceptT e m) a b -> MSFExcept m a b e
try = MSF (ExceptT e m) a b -> MSFExcept m a b e
forall (m :: * -> *) a b e.
MSF (ExceptT e m) a b -> MSFExcept m a b e
MSFExcept

-- | Immediately throw the current input as an exception.
currentInput :: Monad m => MSFExcept m e b e
currentInput :: MSFExcept m e b e
currentInput = MSF (ExceptT e m) e b -> MSFExcept m e b e
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try MSF (ExceptT e m) e b
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS

-- | Functor instance for MSFs on the 'Either' monad. Fmapping is the same as
-- applying a transformation to the 'Left' values.
instance Monad m => Functor (MSFExcept m a b) where
  fmap :: (a -> b) -> MSFExcept m a b a -> MSFExcept m a b b
fmap = (a -> b) -> MSFExcept m a b a -> MSFExcept m a b b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

-- | Applicative instance for MSFs on the 'Either' monad. The function 'pure'
-- throws an exception.
instance Monad m => Applicative (MSFExcept m a b) where
  pure :: a -> MSFExcept m a b a
pure = MSF (ExceptT a m) a b -> MSFExcept m a b a
forall (m :: * -> *) a b e.
MSF (ExceptT e m) a b -> MSFExcept m a b e
MSFExcept (MSF (ExceptT a m) a b -> MSFExcept m a b a)
-> (a -> MSF (ExceptT a m) a b) -> a -> MSFExcept m a b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MSF (ExceptT a m) a b
forall (m :: * -> *) e a b. Monad m => e -> MSF (ExceptT e m) a b
throw
  <*> :: MSFExcept m a b (a -> b) -> MSFExcept m a b a -> MSFExcept m a b b
(<*>) = MSFExcept m a b (a -> b) -> MSFExcept m a b a -> MSFExcept m a b b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- | Monad instance for 'MSFExcept'. Bind uses the exception as the 'return'
-- value in the monad.
instance Monad m => Monad (MSFExcept m a b) where
  return :: a -> MSFExcept m a b a
return = a -> MSFExcept m a b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  MSFExcept MSF (ExceptT a m) a b
msf >>= :: MSFExcept m a b a -> (a -> MSFExcept m a b b) -> MSFExcept m a b b
>>= a -> MSFExcept m a b b
f = MSF (ExceptT b m) a b -> MSFExcept m a b b
forall (m :: * -> *) a b e.
MSF (ExceptT e m) a b -> MSFExcept m a b e
MSFExcept (MSF (ExceptT b m) a b -> MSFExcept m a b b)
-> MSF (ExceptT b m) a b -> MSFExcept m a b b
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT a m) a b
-> (a -> MSF (ExceptT b m) a b) -> MSF (ExceptT b m) a b
forall (m :: * -> *) e1 a b e2.
Monad m =>
MSF (ExceptT e1 m) a b
-> (e1 -> MSF (ExceptT e2 m) a b) -> MSF (ExceptT e2 m) a b
handleExceptT MSF (ExceptT a m) a b
msf ((a -> MSF (ExceptT b m) a b) -> MSF (ExceptT b m) a b)
-> (a -> MSF (ExceptT b m) a b) -> MSF (ExceptT b m) a b
forall a b. (a -> b) -> a -> b
$ MSFExcept m a b b -> MSF (ExceptT b m) a b
forall (m :: * -> *) a b e.
MSFExcept m a b e -> MSF (ExceptT e m) a b
runMSFExcept (MSFExcept m a b b -> MSF (ExceptT b m) a b)
-> (a -> MSFExcept m a b b) -> a -> MSF (ExceptT b m) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MSFExcept m a b b
f

-- | Execute an MSF and, if it throws an exception, recover by switing to a
-- second MSF.
handleExceptT :: Monad m
              => MSF (ExceptT e1 m) a b
              -> (e1 -> MSF (ExceptT e2 m) a b)
              -> MSF (ExceptT e2 m) a b
handleExceptT :: MSF (ExceptT e1 m) a b
-> (e1 -> MSF (ExceptT e2 m) a b) -> MSF (ExceptT e2 m) a b
handleExceptT MSF (ExceptT e1 m) a b
msf e1 -> MSF (ExceptT e2 m) a b
f = ((a
  -> ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
  -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b))
 -> MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) a b)
-> MSF (ExceptT e1 m) a b
-> (a
    -> ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
    -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b))
-> MSF (ExceptT e2 m) a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a
 -> ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
 -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b))
-> MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) a b
forall a (m1 :: * -> *) b1 (m2 :: * -> *) b2.
(a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2))
-> MSF m1 a b1 -> MSF m2 a b2
handleGen MSF (ExceptT e1 m) a b
msf ((a
  -> ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
  -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b))
 -> MSF (ExceptT e2 m) a b)
-> (a
    -> ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
    -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b))
-> MSF (ExceptT e2 m) a b
forall a b. (a -> b) -> a -> b
$ \a
a ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
mbcont -> do
  Either e1 (b, MSF (ExceptT e1 m) a b)
ebcont <- m (Either e1 (b, MSF (ExceptT e1 m) a b))
-> ExceptT e2 m (Either e1 (b, MSF (ExceptT e1 m) a b))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either e1 (b, MSF (ExceptT e1 m) a b))
 -> ExceptT e2 m (Either e1 (b, MSF (ExceptT e1 m) a b)))
-> m (Either e1 (b, MSF (ExceptT e1 m) a b))
-> ExceptT e2 m (Either e1 (b, MSF (ExceptT e1 m) a b))
forall a b. (a -> b) -> a -> b
$ ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
-> m (Either e1 (b, MSF (ExceptT e1 m) a b))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e1 m (b, MSF (ExceptT e1 m) a b)
mbcont
  case Either e1 (b, MSF (ExceptT e1 m) a b)
ebcont of
    Left e1
e          -> MSF (ExceptT e2 m) a b
-> a -> ExceptT e2 m (b, MSF (ExceptT e2 m) a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (e1 -> MSF (ExceptT e2 m) a b
f e1
e) a
a
    Right (b
b, MSF (ExceptT e1 m) a b
msf') -> (b, MSF (ExceptT e2 m) a b)
-> ExceptT e2 m (b, MSF (ExceptT e2 m) a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, MSF (ExceptT e1 m) a b
-> (e1 -> MSF (ExceptT e2 m) a b) -> MSF (ExceptT e2 m) a b
forall (m :: * -> *) e1 a b e2.
Monad m =>
MSF (ExceptT e1 m) a b
-> (e1 -> MSF (ExceptT e2 m) a b) -> MSF (ExceptT e2 m) a b
handleExceptT MSF (ExceptT e1 m) a b
msf' e1 -> MSF (ExceptT e2 m) a b
f)

-- | If no exception can occur, the 'MSF' can be executed without the 'ExceptT'
-- layer.
safely :: Monad m => MSFExcept m a b Void -> MSF m a b
safely :: MSFExcept m a b Void -> MSF m a b
safely (MSFExcept MSF (ExceptT Void m) a b
msf) = (forall c. ExceptT Void m c -> m c)
-> MSF (ExceptT Void m) a b -> MSF m a b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall c. ExceptT Void m c -> m c
forall (m :: * -> *) a b. Monad m => ExceptT a m b -> m b
fromExcept MSF (ExceptT Void m) a b
msf
  where
    -- We can assume that the pattern @Left e@ will not occur, since @e@ would
    -- have to be of type @Void@.
    fromExcept :: ExceptT a m b -> m b
fromExcept ExceptT a m b
ma = do
      Either a b
rightMa <- ExceptT a m b -> m (Either a b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT a m b
ma
      b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ b -> Either a b -> b
forall b a. b -> Either a b -> b
fromRight ([Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"safely: Received `Left`") Either a b
rightMa

-- | An 'MSF' without an 'ExceptT' layer never throws an exception, and can
-- thus have an arbitrary exception type.
safe :: Monad m => MSF m a b -> MSFExcept m a b e
safe :: MSF m a b -> MSFExcept m a b e
safe = MSF (ExceptT e m) a b -> MSFExcept m a b e
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try (MSF (ExceptT e m) a b -> MSFExcept m a b e)
-> (MSF m a b -> MSF (ExceptT e m) a b)
-> MSF m a b
-> MSFExcept m a b e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSF m a b -> MSF (ExceptT e m) a b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS

-- | Inside the 'MSFExcept' monad, execute an action of the wrapped monad.
-- This passes the last input value to the action, but doesn't advance a tick.
once :: Monad m => (a -> m e) -> MSFExcept m a b e
once :: (a -> m e) -> MSFExcept m a b e
once a -> m e
f = MSF (ExceptT e m) a b -> MSFExcept m a b e
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try (MSF (ExceptT e m) a b -> MSFExcept m a b e)
-> MSF (ExceptT e m) a b -> MSFExcept m a b e
forall a b. (a -> b) -> a -> b
$ (a -> ExceptT e m e) -> MSF (ExceptT e m) a e
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (m e -> ExceptT e m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m e -> ExceptT e m e) -> (a -> m e) -> a -> ExceptT e m e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m e
f) MSF (ExceptT e m) a e
-> MSF (ExceptT e m) e b -> MSF (ExceptT e m) a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF (ExceptT e m) e b
forall (m :: * -> *) e a. Monad m => MSF (ExceptT e m) e a
throwS

-- | Variant of 'once' without input.
once_ :: Monad m => m e -> MSFExcept m a b e
once_ :: m e -> MSFExcept m a b e
once_ = (a -> m e) -> MSFExcept m a b e
forall (m :: * -> *) a e b.
Monad m =>
(a -> m e) -> MSFExcept m a b e
once ((a -> m e) -> MSFExcept m a b e)
-> (m e -> a -> m e) -> m e -> MSFExcept m a b e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m e -> a -> m e
forall a b. a -> b -> a
const

-- | Advances a single tick with the given Kleisli arrow, and then throws an
-- exception.
step :: Monad m => (a -> m (b, e)) -> MSFExcept m a b e
step :: (a -> m (b, e)) -> MSFExcept m a b e
step a -> m (b, e)
f = MSF (ExceptT e m) a b -> MSFExcept m a b e
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try (MSF (ExceptT e m) a b -> MSFExcept m a b e)
-> MSF (ExceptT e m) a b -> MSFExcept m a b e
forall a b. (a -> b) -> a -> b
$ proc a
a -> do
  Int
n      <- MSF (ExceptT e m) () Int
forall n (m :: * -> *) a. (Num n, Monad m) => MSF m a n
count           -< ()
  (b
b, e
e) <- (a -> ExceptT e m (b, e)) -> MSF (ExceptT e m) a (b, e)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (m (b, e) -> ExceptT e m (b, e)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (b, e) -> ExceptT e m (b, e))
-> (a -> m (b, e)) -> a -> ExceptT e m (b, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (b, e)
f) -< a
a
  ()
_      <- MSF (ExceptT e m) (Bool, e) ()
forall (m :: * -> *) e. Monad m => MSF (ExceptT e m) (Bool, e) ()
throwOn'        -< (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
1 :: Int), e
e)
  MSF (ExceptT e m) b b
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                   -< b
b

-- | Advances a single tick outputting the value, and then throws '()'.
step_ :: Monad m => b -> MSFExcept m a b ()
step_ :: b -> MSFExcept m a b ()
step_ b
b = (a -> m (b, ())) -> MSFExcept m a b ()
forall (m :: * -> *) a b e.
Monad m =>
(a -> m (b, e)) -> MSFExcept m a b e
step ((a -> m (b, ())) -> MSFExcept m a b ())
-> (a -> m (b, ())) -> MSFExcept m a b ()
forall a b. (a -> b) -> a -> b
$ m (b, ()) -> a -> m (b, ())
forall a b. a -> b -> a
const (m (b, ()) -> a -> m (b, ())) -> m (b, ()) -> a -> m (b, ())
forall a b. (a -> b) -> a -> b
$ (b, ()) -> m (b, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, ())

-- | Converts a list to an 'MSFExcept', which outputs an element of the list at
-- each step, throwing '()' when the list ends.
listToMSFExcept :: Monad m => [b] -> MSFExcept m a b ()
listToMSFExcept :: [b] -> MSFExcept m a b ()
listToMSFExcept = (b -> MSFExcept m a b ()) -> [b] -> MSFExcept m a b ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ b -> MSFExcept m a b ()
forall (m :: * -> *) b a. Monad m => b -> MSFExcept m a b ()
step_

-- * Utilities definable in terms of 'MSFExcept'

-- | Extract an 'MSF' from a monadic action.
--
-- Runs a monadic action that produces an 'MSF' on the first iteration/step,
-- and uses that 'MSF' as the main signal function for all inputs (including
-- the first one).
performOnFirstSample :: Monad m => m (MSF m a b) -> MSF m a b
performOnFirstSample :: m (MSF m a b) -> MSF m a b
performOnFirstSample m (MSF m a b)
sfaction = MSFExcept m a b Void -> MSF m a b
forall (m :: * -> *) a b.
Monad m =>
MSFExcept m a b Void -> MSF m a b
safely (MSFExcept m a b Void -> MSF m a b)
-> MSFExcept m a b Void -> MSF m a b
forall a b. (a -> b) -> a -> b
$ do
  MSF m a b
msf <- m (MSF m a b) -> MSFExcept m a b (MSF m a b)
forall (m :: * -> *) e a b. Monad m => m e -> MSFExcept m a b e
once_ m (MSF m a b)
sfaction
  MSF m a b -> MSFExcept m a b Void
forall (m :: * -> *) a b e.
Monad m =>
MSF m a b -> MSFExcept m a b e
safe MSF m a b
msf

-- | Reactimates an 'MSFExcept' until it throws an exception.
reactimateExcept :: Monad m => MSFExcept m () () e -> m e
reactimateExcept :: MSFExcept m () () e -> m e
reactimateExcept MSFExcept m () () e
msfe = do
  Either e ()
leftMe <- ExceptT e m () -> m (Either e ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m () -> m (Either e ()))
-> ExceptT e m () -> m (Either e ())
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT e m) () () -> ExceptT e m ()
forall (m :: * -> *). Monad m => MSF m () () -> m ()
reactimate (MSF (ExceptT e m) () () -> ExceptT e m ())
-> MSF (ExceptT e m) () () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ MSFExcept m () () e -> MSF (ExceptT e m) () ()
forall (m :: * -> *) a b e.
MSFExcept m a b e -> MSF (ExceptT e m) a b
runMSFExcept MSFExcept m () () e
msfe
  e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> m e) -> e -> m e
forall a b. (a -> b) -> a -> b
$ e -> Either e () -> e
forall a b. a -> Either a b -> a
fromLeft ([Char] -> e
forall a. HasCallStack => [Char] -> a
error [Char]
"reactimateExcept: Received `Right`") Either e ()
leftMe

-- | Reactimates an 'MSF' until it returns 'True'.
reactimateB :: Monad m => MSF m () Bool -> m ()
reactimateB :: MSF m () Bool -> m ()
reactimateB MSF m () Bool
sf = MSFExcept m () () () -> m ()
forall (m :: * -> *) e. Monad m => MSFExcept m () () e -> m e
reactimateExcept (MSFExcept m () () () -> m ()) -> MSFExcept m () () () -> m ()
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT () m) () () -> MSFExcept m () () ()
forall e (m :: * -> *) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try (MSF (ExceptT () m) () () -> MSFExcept m () () ())
-> MSF (ExceptT () m) () () -> MSFExcept m () () ()
forall a b. (a -> b) -> a -> b
$ MSF m () Bool -> MSF (ExceptT () m) () Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS MSF m () Bool
sf MSF (ExceptT () m) () Bool
-> MSF (ExceptT () m) Bool () -> MSF (ExceptT () m) () ()
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> () -> MSF (ExceptT () m) Bool ()
forall (m :: * -> *) e. Monad m => e -> MSF (ExceptT e m) Bool ()
throwOn ()

-- | Run first MSF until the second value in the output tuple is @Just c@ (for
-- some @c@), then start the second MSF.
--
-- Analog to Yampa's
-- [@switch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:switch),
-- with 'Maybe' instead of @Event@.
switch :: Monad m => MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
switch :: MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
switch MSF m a (b, Maybe c)
sf c -> MSF m a b
f = MSF (ExceptT c m) a b -> (c -> MSF m a b) -> MSF m a b
forall (m :: * -> *) e a b.
Monad m =>
MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b
catchS MSF (ExceptT c m) a b
ef c -> MSF m a b
f
  where
    -- Run sf, throwing an exception if there is a no-Nothing value in the
    -- second element of the pair, and returning the first element otherwise.
    ef :: MSF (ExceptT c m) a b
ef = proc a
a -> do
           (b
b, Maybe c
me)  <- MSF m a (b, Maybe c) -> MSF (ExceptT c m) a (b, Maybe c)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS MSF m a (b, Maybe c)
sf  -< a
a
           MSF (ExceptT c m) (Maybe c) (Maybe Any)
forall (m :: * -> *) e a.
Monad m =>
MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe                 -< Maybe c
me
           MSF (ExceptT c m) b b
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                    -< b
b

-- | Run first MSF until the second value in the output tuple is @Just c@ (for
-- some @c@), then start the second MSF.
--
-- Analog to Yampa's
-- [@dswitch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:dSwitch),
-- with 'Maybe' instead of @Event@.
dSwitch :: Monad m => MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
dSwitch :: MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
dSwitch MSF m a (b, Maybe c)
sf c -> MSF m a b
f = MSF (ExceptT c m) a b -> (c -> MSF m a b) -> MSF m a b
forall (m :: * -> *) e a b.
Monad m =>
MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b
catchS MSF (ExceptT c m) a b
ef c -> MSF m a b
f
  where
    ef :: MSF (ExceptT c m) a b
ef = Maybe c
-> MSF (ExceptT c m) (a, Maybe c) (b, Maybe c)
-> MSF (ExceptT c m) a b
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Maybe c
forall a. Maybe a
Nothing (MSF (ExceptT c m) (a, Maybe c) (b, Maybe c)
 -> MSF (ExceptT c m) a b)
-> MSF (ExceptT c m) (a, Maybe c) (b, Maybe c)
-> MSF (ExceptT c m) a b
forall a b. (a -> b) -> a -> b
$ proc (a
a, Maybe c
me) -> do
           MSF (ExceptT c m) (Maybe c) (Maybe Any)
forall (m :: * -> *) e a.
Monad m =>
MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe    -< Maybe c
me
           MSF m a (b, Maybe c) -> MSF (ExceptT c m) a (b, Maybe c)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS MSF m a (b, Maybe c)
sf -< a
a

-- | More general lifting combinator that enables recovery. Note that, unlike a
-- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary
-- function needs to be a bit more structured, and produces a Maybe value. The
-- previous 'MSF' is used if a new one is not produced.
transG :: (Monad m1, Monad m2)
       => (a2 -> m1 a1)
       -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))
       -> MSF m1 a1 b1
       -> MSF m2 a2 b2
transG :: (a2 -> m1 a1)
-> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))
-> MSF m1 a1 b1
-> MSF m2 a2 b2
transG a2 -> m1 a1
transformInput forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)
transformOutput MSF m1 a1 b1
msf = MSF m2 a2 b2
go
  where
    go :: MSF m2 a2 b2
go = (a2 -> m2 (b2, MSF m2 a2 b2)) -> MSF m2 a2 b2
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a2 -> m2 (b2, MSF m2 a2 b2)) -> MSF m2 a2 b2)
-> (a2 -> m2 (b2, MSF m2 a2 b2)) -> MSF m2 a2 b2
forall a b. (a -> b) -> a -> b
$ \a2
a2 -> do
           (b2
b2, Maybe (MSF m1 a1 b1)
msf') <- a2 -> m1 (b1, MSF m1 a1 b1) -> m2 (b2, Maybe (MSF m1 a1 b1))
forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)
transformOutput a2
a2 (m1 (b1, MSF m1 a1 b1) -> m2 (b2, Maybe (MSF m1 a1 b1)))
-> m1 (b1, MSF m1 a1 b1) -> m2 (b2, Maybe (MSF m1 a1 b1))
forall a b. (a -> b) -> a -> b
$ MSF m1 a1 b1 -> a1 -> m1 (b1, MSF m1 a1 b1)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF m1 a1 b1
msf (a1 -> m1 (b1, MSF m1 a1 b1)) -> m1 a1 -> m1 (b1, MSF m1 a1 b1)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a2 -> m1 a1
transformInput a2
a2
           case Maybe (MSF m1 a1 b1)
msf' of
             Just MSF m1 a1 b1
msf'' ->
               (b2, MSF m2 a2 b2) -> m2 (b2, MSF m2 a2 b2)
forall (m :: * -> *) a. Monad m => a -> m a
return (b2
b2, (a2 -> m1 a1)
-> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))
-> MSF m1 a1 b1
-> MSF m2 a2 b2
forall (m1 :: * -> *) (m2 :: * -> *) a2 a1 b1 b2.
(Monad m1, Monad m2) =>
(a2 -> m1 a1)
-> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c))
-> MSF m1 a1 b1
-> MSF m2 a2 b2
transG a2 -> m1 a1
transformInput forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)
transformOutput MSF m1 a1 b1
msf'')
             Maybe (MSF m1 a1 b1)
Nothing ->
               (b2, MSF m2 a2 b2) -> m2 (b2, MSF m2 a2 b2)
forall (m :: * -> *) a. Monad m => a -> m a
return (b2
b2, MSF m2 a2 b2
go)

-- | Use a generic handler to handle exceptions in MSF processing actions.
handleGen :: (a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2))
          -> MSF m1 a b1
          -> MSF m2 a b2
handleGen :: (a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2))
-> MSF m1 a b1 -> MSF m2 a b2
handleGen a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2)
handler MSF m1 a b1
msf = (a -> m2 (b2, MSF m2 a b2)) -> MSF m2 a b2
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> m2 (b2, MSF m2 a b2)) -> MSF m2 a b2)
-> (a -> m2 (b2, MSF m2 a b2)) -> MSF m2 a b2
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2)
handler a
a (MSF m1 a b1 -> a -> m1 (b1, MSF m1 a b1)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF m1 a b1
msf a
a)