module FRP.Rhine.Clock.Except where

-- base
import Control.Arrow
import Control.Exception
import Control.Exception qualified as Exception
import Control.Monad ((<=<))
import Data.Functor ((<&>))
import Data.Void

-- time
import Data.Time (UTCTime, getCurrentTime)

-- mtl
import Control.Monad.Error.Class
import Control.Monad.IO.Class (MonadIO, liftIO)

-- time-domain
import Data.TimeDomain (TimeDomain)

-- automaton
import Data.Automaton (hoistS)
import Data.Automaton.Trans.Except
import Data.Automaton.Trans.Except qualified as AutomatonExcept
import Data.Automaton.Trans.Reader (readerS, runReaderS)

-- rhine
import FRP.Rhine.ClSF.Core (ClSF)
import FRP.Rhine.Clock (
  Clock (..),
  HoistClock (..),
  TimeInfo (..),
  retag,
 )
import FRP.Rhine.Clock.Proxy (GetClockProxy)

-- * 'ExceptClock'

{- | Handle 'IO' exceptions purely in 'ExceptT'.

The clock @cl@ may throw 'Exception's of type @e@ while running.
These exceptions are automatically caught, and raised as an error in 'ExceptT'
(or more generally in 'MonadError', which implies the presence of 'ExceptT' in the monad transformer stack)

It can then be caught and handled with 'CatchClock'.
-}
newtype ExceptClock cl e = ExceptClock {forall cl e. ExceptClock cl e -> cl
getExceptClock :: cl}

instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio (ExceptClock cl e) where
  type Time (ExceptClock cl e) = Time cl
  type Tag (ExceptClock cl e) = Tag cl

  initClock :: ExceptClock cl e
-> RunningClockInit
     eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e))
initClock ExceptClock {cl
getExceptClock :: forall cl e. ExceptClock cl e -> cl
getExceptClock :: cl
getExceptClock} = do
    IO
  (Either
     e
     (RunningClock
        eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
      Time (ExceptClock cl e)))
-> RunningClockInit
     eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e))
forall e (eio :: Type -> Type) a.
(MonadError e eio, MonadIO eio) =>
IO (Either e a) -> eio a
ioerror (IO
   (Either
      e
      (RunningClock
         eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
       Time (ExceptClock cl e)))
 -> RunningClockInit
      eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)))
-> IO
     (Either
        e
        (RunningClock
           eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
         Time (ExceptClock cl e)))
-> RunningClockInit
     eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e))
forall a b. (a -> b) -> a -> b
$
      IO
  (RunningClock
     eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
   Time (ExceptClock cl e))
-> IO
     (Either
        e
        (RunningClock
           eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
         Time (ExceptClock cl e)))
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO
   (RunningClock
      eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
    Time (ExceptClock cl e))
 -> IO
      (Either
         e
         (RunningClock
            eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
          Time (ExceptClock cl e))))
-> IO
     (RunningClock
        eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
      Time (ExceptClock cl e))
-> IO
     (Either
        e
        (RunningClock
           eio (Time (ExceptClock cl e)) (Tag (ExceptClock cl e)),
         Time (ExceptClock cl e)))
forall a b. (a -> b) -> a -> b
$
        cl -> IO (RunningClock IO (Time cl) (Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
getExceptClock
          IO (RunningClock IO (Time cl) (Tag cl), Time cl)
-> ((RunningClock IO (Time cl) (Tag cl), Time cl)
    -> (RunningClock eio (Time cl) (Tag cl), Time cl))
-> IO (RunningClock eio (Time cl) (Tag cl), Time cl)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (RunningClock IO (Time cl) (Tag cl)
 -> RunningClock eio (Time cl) (Tag cl))
-> (RunningClock IO (Time cl) (Tag cl), Time cl)
-> (RunningClock eio (Time cl) (Tag cl), Time cl)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((forall x. IO x -> eio x)
-> RunningClock IO (Time cl) (Tag cl)
-> RunningClock eio (Time cl) (Tag cl)
forall (m :: Type -> Type) (n :: Type -> Type) a b.
Monad m =>
(forall x. m x -> n x) -> Automaton m a b -> Automaton n a b
hoistS (IO (Either e x) -> eio x
forall e (eio :: Type -> Type) a.
(MonadError e eio, MonadIO eio) =>
IO (Either e a) -> eio a
ioerror (IO (Either e x) -> eio x)
-> (IO x -> IO (Either e x)) -> IO x -> eio x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO x -> IO (Either e x)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try))
    where
      ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
      ioerror :: forall e (eio :: Type -> Type) a.
(MonadError e eio, MonadIO eio) =>
IO (Either e a) -> eio a
ioerror = Either e a -> eio a
forall e (m :: Type -> Type) a. MonadError e m => Either e a -> m a
liftEither (Either e a -> eio a)
-> (IO (Either e a) -> eio (Either e a))
-> IO (Either e a)
-> eio a
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either e a) -> eio (Either e a)
forall a. IO a -> eio a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO

instance GetClockProxy (ExceptClock cl e)

-- * 'CatchClock'

{- | Catch an exception in one clock and proceed with another.

When @cl1@ throws an exception @e@ (in @'ExceptT' e@) while running,
this exception is caught, and a clock @cl2@ is started from the exception value.

For this to be possible, @cl1@ must run in the monad @'ExceptT' e m@, while @cl2@ must run in @m@.
To give @cl2@ the ability to throw another exception, you need to add a further 'ExceptT' layer to the stack in @m@.
-}
data CatchClock cl1 e cl2 = CatchClock cl1 (e -> cl2)

instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => Clock m (CatchClock cl1 e cl2) where
  type Time (CatchClock cl1 e cl2) = Time cl1
  type Tag (CatchClock cl1 e cl2) = Either (Tag cl2) (Tag cl1)
  initClock :: CatchClock cl1 e cl2
-> RunningClockInit
     m (Time (CatchClock cl1 e cl2)) (Tag (CatchClock cl1 e cl2))
initClock (CatchClock cl1
cl1 e -> cl2
handler) = do
    Either
  e
  (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
   Time cl2)
tryToInit <- ExceptT
  e
  m
  (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
   Time cl2)
-> m (Either
        e
        (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
         Time cl2))
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   e
   m
   (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
    Time cl2)
 -> m (Either
         e
         (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
          Time cl2)))
-> ExceptT
     e
     m
     (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
-> m (Either
        e
        (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
         Time cl2))
forall a b. (a -> b) -> a -> b
$ (Automaton (ExceptT e m) () (Time cl2, Tag cl1)
 -> Automaton
      (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)))
-> (Automaton (ExceptT e m) () (Time cl2, Tag cl1), Time cl2)
-> (Automaton
      (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
    Time cl2)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Automaton (ExceptT e m) () (Time cl2, Tag cl1)
-> Automaton
     (ExceptT e m)
     (Time cl2, Tag cl1)
     (Time cl2, Either (Tag cl2) (Tag cl1))
-> Automaton
     (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1))
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl2, Tag cl1) -> (Time cl2, Either (Tag cl2) (Tag cl1)))
-> Automaton
     (ExceptT e m)
     (Time cl2, Tag cl1)
     (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c. (b -> c) -> Automaton (ExceptT e m) b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((Tag cl1 -> Either (Tag cl2) (Tag cl1))
-> (Time cl2, Tag cl1) -> (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Tag cl1 -> Either (Tag cl2) (Tag cl1)
forall a b. b -> Either a b
Right)) ((Automaton (ExceptT e m) () (Time cl2, Tag cl1), Time cl2)
 -> (Automaton
       (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
     Time cl2))
-> ExceptT
     e m (Automaton (ExceptT e m) () (Time cl2, Tag cl1), Time cl2)
-> ExceptT
     e
     m
     (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> cl1 -> RunningClockInit (ExceptT e m) (Time cl1) (Tag cl1)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl1
cl1
    case Either
  e
  (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1)),
   Time cl2)
tryToInit of
      Right (Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1))
runningClock, Time cl2
initTime) -> do
        let catchingClock :: Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
catchingClock = AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void
-> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
forall (m :: Type -> Type) a b.
Monad m =>
AutomatonExcept a b m Void -> Automaton m a b
safely (AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void
 -> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)))
-> AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void
-> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
forall a b. (a -> b) -> a -> b
$ do
              e
e <- Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1))
-> AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m e
forall (m :: Type -> Type) e a b.
Monad m =>
Automaton (ExceptT e m) a b -> AutomatonExcept a b m e
AutomatonExcept.try Automaton (ExceptT e m) () (Time cl2, Either (Tag cl2) (Tag cl1))
runningClock
              let cl2 :: cl2
cl2 = e -> cl2
handler e
e
              (Automaton m () (Time cl2, Tag cl2)
runningClock', Time cl2
_) <- m (Automaton m () (Time cl2, Tag cl2), Time cl2)
-> AutomatonExcept
     ()
     (Time cl2, Either (Tag cl2) (Tag cl1))
     m
     (Automaton m () (Time cl2, Tag cl2), Time cl2)
forall (m :: Type -> Type) e a b.
Monad m =>
m e -> AutomatonExcept a b m e
once_ (m (Automaton m () (Time cl2, Tag cl2), Time cl2)
 -> AutomatonExcept
      ()
      (Time cl2, Either (Tag cl2) (Tag cl1))
      m
      (Automaton m () (Time cl2, Tag cl2), Time cl2))
-> m (Automaton m () (Time cl2, Tag cl2), Time cl2)
-> AutomatonExcept
     ()
     (Time cl2, Either (Tag cl2) (Tag cl1))
     m
     (Automaton m () (Time cl2, Tag cl2), Time cl2)
forall a b. (a -> b) -> a -> b
$ cl2 -> m (Automaton m () (Time cl2, Tag cl2), Time cl2)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl2
cl2
              Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
-> AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void
forall (m :: Type -> Type) a b e.
Monad m =>
Automaton m a b -> AutomatonExcept a b m e
safe (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
 -> AutomatonExcept
      () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void)
-> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
-> AutomatonExcept () (Time cl2, Either (Tag cl2) (Tag cl1)) m Void
forall a b. (a -> b) -> a -> b
$ Automaton m () (Time cl2, Tag cl2)
runningClock' Automaton m () (Time cl2, Tag cl2)
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl2) (Tag cl1))
-> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl2) (Tag cl1)))
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((Tag cl2 -> Either (Tag cl2) (Tag cl1))
-> (Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Tag cl2 -> Either (Tag cl2) (Tag cl1)
forall a b. a -> Either a b
Left)
        (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)), Time cl2)
-> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
catchingClock, Time cl2
initTime)
      Left e
e -> (((Automaton m () (Time cl2, Tag cl2), Time cl2)
 -> (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
     Time cl2))
-> m (Automaton m () (Time cl2, Tag cl2), Time cl2)
-> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Automaton m () (Time cl2, Tag cl2)
 -> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)))
-> (Automaton m () (Time cl2, Tag cl2), Time cl2)
-> (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
    Time cl2)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Automaton m () (Time cl2, Tag cl2)
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl2) (Tag cl1))
-> Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1))
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl2) (Tag cl1)))
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((Tag cl2 -> Either (Tag cl2) (Tag cl1))
-> (Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl2) (Tag cl1))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Tag cl2 -> Either (Tag cl2) (Tag cl1)
forall a b. a -> Either a b
Left))) (m (Automaton m () (Time cl2, Tag cl2), Time cl2)
 -> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
       Time cl2))
-> (cl2 -> m (Automaton m () (Time cl2, Tag cl2), Time cl2))
-> cl2
-> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cl2 -> m (Automaton m () (Time cl2, Tag cl2), Time cl2)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock) (cl2
 -> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
       Time cl2))
-> cl2
-> m (Automaton m () (Time cl2, Either (Tag cl2) (Tag cl1)),
      Time cl2)
forall a b. (a -> b) -> a -> b
$ e -> cl2
handler e
e

instance (GetClockProxy (CatchClock cl1 e cl2))

-- | Combine two 'ClSF's under two different clocks.
catchClSF ::
  (Time cl1 ~ Time cl2, Monad m) =>
  -- | Executed until @cl1@ throws an exception
  ClSF m cl1 a b ->
  -- | Executed after @cl1@ threw an exception, when @cl2@ is started
  ClSF m cl2 a b ->
  ClSF m (CatchClock cl1 e cl2) a b
catchClSF :: forall cl1 cl2 (m :: Type -> Type) a b e.
(Time cl1 ~ Time cl2, Monad m) =>
ClSF m cl1 a b
-> ClSF m cl2 a b -> ClSF m (CatchClock cl1 e cl2) a b
catchClSF ClSF m cl1 a b
clsf1 ClSF m cl2 a b
clsf2 = Automaton m (TimeInfo (CatchClock cl1 e cl2), a) b
-> Automaton (ReaderT (TimeInfo (CatchClock cl1 e cl2)) m) a b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton m (r, a) b -> Automaton (ReaderT r m) a b
readerS (Automaton m (TimeInfo (CatchClock cl1 e cl2), a) b
 -> Automaton (ReaderT (TimeInfo (CatchClock cl1 e cl2)) m) a b)
-> Automaton m (TimeInfo (CatchClock cl1 e cl2), a) b
-> Automaton (ReaderT (TimeInfo (CatchClock cl1 e cl2)) m) a b
forall a b. (a -> b) -> a -> b
$ proc (TimeInfo (CatchClock cl1 e cl2)
timeInfo, a
a) -> do
  case TimeInfo (CatchClock cl1 e cl2) -> Tag (CatchClock cl1 e cl2)
forall cl. TimeInfo cl -> Tag cl
tag TimeInfo (CatchClock cl1 e cl2)
timeInfo of
    Right Tag cl1
tag1 -> ClSF m cl1 a b -> Automaton m (TimeInfo cl1, a) b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton (ReaderT r m) a b -> Automaton m (r, a) b
runReaderS ClSF m cl1 a b
clsf1 -< ((Tag (CatchClock cl1 e cl2) -> Tag cl1)
-> TimeInfo (CatchClock cl1 e cl2) -> TimeInfo cl1
forall cl1 cl2.
(Time cl1 ~ Time cl2) =>
(Tag cl1 -> Tag cl2) -> TimeInfo cl1 -> TimeInfo cl2
retag (Tag cl1 -> Either (Tag cl2) (Tag cl1) -> Tag cl1
forall a b. a -> b -> a
const Tag cl1
tag1) TimeInfo (CatchClock cl1 e cl2)
timeInfo, a
a)
    Left Tag cl2
tag2 -> ClSF m cl2 a b -> Automaton m (TimeInfo cl2, a) b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton (ReaderT r m) a b -> Automaton m (r, a) b
runReaderS ClSF m cl2 a b
clsf2 -< ((Tag (CatchClock cl1 e cl2) -> Tag cl2)
-> TimeInfo (CatchClock cl1 e cl2) -> TimeInfo cl2
forall cl1 cl2.
(Time cl1 ~ Time cl2) =>
(Tag cl1 -> Tag cl2) -> TimeInfo cl1 -> TimeInfo cl2
retag (Tag cl2 -> Either (Tag cl2) (Tag cl1) -> Tag cl2
forall a b. a -> b -> a
const Tag cl2
tag2) TimeInfo (CatchClock cl1 e cl2)
timeInfo, a
a)

-- * 'SafeClock'

-- | A clock that throws no exceptions.
type SafeClock m = HoistClock (ExceptT Void m) m

-- | Remove 'ExceptT' from the monad of a clock, proving that no exception can be thrown.
safeClock :: (Functor m) => cl -> SafeClock m cl
safeClock :: forall (m :: Type -> Type) cl. Functor m => cl -> SafeClock m cl
safeClock cl
unhoistedClock =
  HoistClock
    { cl
unhoistedClock :: cl
unhoistedClock :: cl
unhoistedClock
    , monadMorphism :: forall a. ExceptT Void m a -> m a
monadMorphism = (Either Void a -> a) -> m (Either Void a) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Void -> a) -> (a -> a) -> Either Void a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> a
forall a. Void -> a
absurd a -> a
forall a. a -> a
id) (m (Either Void a) -> m a)
-> (ExceptT Void m a -> m (Either Void a))
-> ExceptT Void m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Void m a -> m (Either Void a)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT
    }

-- * 'Single' clock

{- | A clock that emits a single tick, and then throws an exception.

The tag, time measurement and exception have to be supplied as clock value.
-}
data Single m time tag e = Single
  { forall (m :: Type -> Type) time tag e. Single m time tag e -> tag
singleTag :: tag
  -- ^ The tag that will be emitted on the tick.
  , forall (m :: Type -> Type) time tag e.
Single m time tag e -> m time
getTime :: m time
  -- ^ A method to measure the current time.
  , forall (m :: Type -> Type) time tag e. Single m time tag e -> e
exception :: e
  -- ^ The exception to throw after the single tick.
  }

instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) where
  type Time (Single m time tag e) = time
  type Tag (Single m time tag e) = tag
  initClock :: Single m time tag e
-> RunningClockInit
     m (Time (Single m time tag e)) (Tag (Single m time tag e))
initClock Single {tag
singleTag :: forall (m :: Type -> Type) time tag e. Single m time tag e -> tag
singleTag :: tag
singleTag, m time
getTime :: forall (m :: Type -> Type) time tag e.
Single m time tag e -> m time
getTime :: m time
getTime, e
exception :: forall (m :: Type -> Type) time tag e. Single m time tag e -> e
exception :: e
exception} = do
    time
initTime <- m time
getTime
    let runningClock :: Automaton m () (time, tag)
runningClock = (forall x. ExceptT e m x -> m x)
-> Automaton (ExceptT e m) () (time, tag)
-> Automaton m () (time, tag)
forall (m :: Type -> Type) (n :: Type -> Type) a b.
Monad m =>
(forall x. m x -> n x) -> Automaton m a b -> Automaton n a b
hoistS (m (Either e x) -> m x
forall e (m :: Type -> Type) a.
MonadError e m =>
m (Either e a) -> m a
errorT (m (Either e x) -> m x)
-> (ExceptT e m x -> m (Either e x)) -> ExceptT e m x -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m x -> m (Either e x)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT) (Automaton (ExceptT e m) () (time, tag)
 -> Automaton m () (time, tag))
-> Automaton (ExceptT e m) () (time, tag)
-> Automaton m () (time, tag)
forall a b. (a -> b) -> a -> b
$ AutomatonExcept () (time, tag) m e
-> Automaton (ExceptT e m) () (time, tag)
forall (m :: Type -> Type) a b e.
Monad m =>
AutomatonExcept a b m e -> Automaton (ExceptT e m) a b
runAutomatonExcept (AutomatonExcept () (time, tag) m e
 -> Automaton (ExceptT e m) () (time, tag))
-> AutomatonExcept () (time, tag) m e
-> Automaton (ExceptT e m) () (time, tag)
forall a b. (a -> b) -> a -> b
$ do
          (time, tag) -> AutomatonExcept () (time, tag) m ()
forall (m :: Type -> Type) b a.
Monad m =>
b -> AutomatonExcept a b m ()
step_ (time
initTime, tag
singleTag)
          e -> AutomatonExcept () (time, tag) m e
forall a. a -> AutomatonExcept () (time, tag) m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return e
exception
        errorT :: (MonadError e m) => m (Either e a) -> m a
        errorT :: forall e (m :: Type -> Type) a.
MonadError e m =>
m (Either e a) -> m a
errorT = (m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> m a
forall e (m :: Type -> Type) a. MonadError e m => Either e a -> m a
liftEither)
    (Automaton m () (time, tag), time)
-> m (Automaton m () (time, tag), time)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Automaton m () (time, tag)
runningClock, time
initTime)

-- * 'DelayException'

{- | Catch an exception in clock @cl@ and throw it after one time step.

This is particularly useful if you want to give your signal network a chance to save its current state in some way.
-}
type DelayException m time cl e1 e2 = CatchClock cl e1 (Single m time e1 e2)

-- | Construct a 'DelayException' clock.
delayException ::
  (Monad m, Clock (ExceptT e1 m) cl, MonadError e2 m) =>
  -- | The clock that will throw an exception @e@
  cl ->
  -- | How to transform the exception into the new exception that will be thrown later
  (e1 -> e2) ->
  -- | How to measure the current time
  m (Time cl) ->
  DelayException m (Time cl) cl e1 e2
delayException :: forall (m :: Type -> Type) e1 cl e2.
(Monad m, Clock (ExceptT e1 m) cl, MonadError e2 m) =>
cl
-> (e1 -> e2) -> m (Time cl) -> DelayException m (Time cl) cl e1 e2
delayException cl
cl e1 -> e2
handler m (Time cl)
mTime = cl
-> (e1 -> Single m (Time cl) e1 e2)
-> CatchClock cl e1 (Single m (Time cl) e1 e2)
forall cl1 e cl2. cl1 -> (e -> cl2) -> CatchClock cl1 e cl2
CatchClock cl
cl ((e1 -> Single m (Time cl) e1 e2)
 -> CatchClock cl e1 (Single m (Time cl) e1 e2))
-> (e1 -> Single m (Time cl) e1 e2)
-> CatchClock cl e1 (Single m (Time cl) e1 e2)
forall a b. (a -> b) -> a -> b
$ \e1
e -> e1 -> m (Time cl) -> e2 -> Single m (Time cl) e1 e2
forall (m :: Type -> Type) time tag e.
tag -> m time -> e -> Single m time tag e
Single e1
e m (Time cl)
mTime (e2 -> Single m (Time cl) e1 e2) -> e2 -> Single m (Time cl) e1 e2
forall a b. (a -> b) -> a -> b
$ e1 -> e2
handler e1
e

-- | Like 'delayException', but the exception thrown by @cl@ and by the @DelayException@ clock are the same.
delayException' :: (Monad m, MonadError e m, Clock (ExceptT e m) cl) => cl -> m (Time cl) -> DelayException m (Time cl) cl e e
delayException' :: forall (m :: Type -> Type) e cl.
(Monad m, MonadError e m, Clock (ExceptT e m) cl) =>
cl -> m (Time cl) -> DelayException m (Time cl) cl e e
delayException' cl
cl = cl
-> (e -> e)
-> m (Time cl)
-> CatchClock cl e (Single m (Time cl) e e)
forall (m :: Type -> Type) e1 cl e2.
(Monad m, Clock (ExceptT e1 m) cl, MonadError e2 m) =>
cl
-> (e1 -> e2) -> m (Time cl) -> DelayException m (Time cl) cl e1 e2
delayException cl
cl e -> e
forall a. a -> a
id

-- | Catch an 'IO' 'Exception', and throw it after one time step.
type DelayMonadIOException m cl e1 e2 = DelayException m UTCTime (ExceptClock cl e1) e1 e2

-- | Build a 'DelayMonadIOException'. The time will be measured using the system time.
delayMonadIOException :: (Exception e1, MonadIO m, MonadError e2 m, Clock IO cl, Time cl ~ UTCTime) => cl -> (e1 -> e2) -> DelayMonadIOException m cl e1 e2
delayMonadIOException :: forall e1 (m :: Type -> Type) e2 cl.
(Exception e1, MonadIO m, MonadError e2 m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayMonadIOException m cl e1 e2
delayMonadIOException cl
cl e1 -> e2
handler = ExceptClock cl e1
-> (e1 -> e2)
-> m (Time (ExceptClock cl e1))
-> CatchClock
     (ExceptClock cl e1) e1 (Single m (Time (ExceptClock cl e1)) e1 e2)
forall (m :: Type -> Type) e1 cl e2.
(Monad m, Clock (ExceptT e1 m) cl, MonadError e2 m) =>
cl
-> (e1 -> e2) -> m (Time cl) -> DelayException m (Time cl) cl e1 e2
delayException (cl -> ExceptClock cl e1
forall cl e. cl -> ExceptClock cl e
ExceptClock cl
cl) e1 -> e2
handler (m (Time (ExceptClock cl e1))
 -> CatchClock
      (ExceptClock cl e1) e1 (Single m (Time (ExceptClock cl e1)) e1 e2))
-> m (Time (ExceptClock cl e1))
-> CatchClock
     (ExceptClock cl e1) e1 (Single m (Time (ExceptClock cl e1)) e1 e2)
forall a b. (a -> b) -> a -> b
$ IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

-- | 'DelayMonadIOException' specialised to 'IOError'.
type DelayMonadIOError m cl e = DelayMonadIOException m cl IOError e

-- | 'delayMonadIOException' specialised to 'IOError'.
delayMonadIOError :: (Exception e, MonadError e m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> (IOError -> e) -> DelayMonadIOError m cl e
delayMonadIOError :: forall e (m :: Type -> Type) cl.
(Exception e, MonadError e m, MonadIO m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> (IOError -> e) -> DelayMonadIOError m cl e
delayMonadIOError = cl -> (IOError -> e) -> DelayMonadIOException m cl IOError e
forall e1 (m :: Type -> Type) e2 cl.
(Exception e1, MonadIO m, MonadError e2 m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayMonadIOException m cl e1 e2
delayMonadIOException

-- | Like 'delayMonadIOError', but throw the error without transforming it.
delayMonadIOError' :: (MonadError IOError m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayMonadIOError m cl IOError
delayMonadIOError' :: forall (m :: Type -> Type) cl.
(MonadError IOError m, MonadIO m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> DelayMonadIOError m cl IOError
delayMonadIOError' cl
cl = cl -> (IOError -> IOError) -> DelayMonadIOError m cl IOError
forall e (m :: Type -> Type) cl.
(Exception e, MonadError e m, MonadIO m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> (IOError -> e) -> DelayMonadIOError m cl e
delayMonadIOError cl
cl IOError -> IOError
forall a. a -> a
id

{- | 'DelayMonadIOException' specialised to the monad @'ExceptT' e2 'IO'@.

This is sometimes helpful when the type checker complains about an ambigous monad type variable.
-}
type DelayIOException cl e1 e2 = DelayException (ExceptT e2 IO) UTCTime (ExceptClock cl e1) e1 e2

-- | 'delayMonadIOException' specialised to the monad @'ExceptT' e2 'IO'@.
delayIOException :: (Exception e1, Clock IO cl, Time cl ~ UTCTime) => cl -> (e1 -> e2) -> DelayIOException cl e1 e2
delayIOException :: forall e1 cl e2.
(Exception e1, Clock IO cl, Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayIOException cl e1 e2
delayIOException = cl -> (e1 -> e2) -> DelayMonadIOException (ExceptT e2 IO) cl e1 e2
forall e1 (m :: Type -> Type) e2 cl.
(Exception e1, MonadIO m, MonadError e2 m, Clock IO cl,
 Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayMonadIOException m cl e1 e2
delayMonadIOException

-- | 'delayIOException'', but throw the error without transforming it.
delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
delayIOException' :: forall e cl.
(Exception e, Clock IO cl, Time cl ~ UTCTime) =>
cl -> DelayIOException cl e e
delayIOException' cl
cl = cl -> (e -> e) -> DelayIOException cl e e
forall e1 cl e2.
(Exception e1, Clock IO cl, Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayIOException cl e1 e2
delayIOException cl
cl e -> e
forall a. a -> a
id

-- | 'DelayIOException' specialised to 'IOError'.
type DelayIOError cl e = DelayIOException cl IOError e

-- | 'delayIOException' specialised to 'IOError'.
delayIOError :: (Time cl ~ UTCTime, Clock IO cl) => cl -> (IOError -> e) -> DelayIOError cl e
delayIOError :: forall cl e.
(Time cl ~ UTCTime, Clock IO cl) =>
cl -> (IOError -> e) -> DelayIOError cl e
delayIOError = cl -> (IOError -> e) -> DelayIOException cl IOError e
forall e1 cl e2.
(Exception e1, Clock IO cl, Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayIOException cl e1 e2
delayIOException

-- | 'delayIOError', but throw the error without transforming it.
delayIOError' :: (Time cl ~ UTCTime, Clock IO cl) => cl -> DelayIOError cl IOError
delayIOError' :: forall cl.
(Time cl ~ UTCTime, Clock IO cl) =>
cl -> DelayIOError cl IOError
delayIOError' cl
cl = cl -> (IOError -> IOError) -> DelayIOException cl IOError IOError
forall e1 cl e2.
(Exception e1, Clock IO cl, Time cl ~ UTCTime) =>
cl -> (e1 -> e2) -> DelayIOException cl e1 e2
delayIOException cl
cl IOError -> IOError
forall a. a -> a
id