Except.hs

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 {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 {getExceptClock} = do
    ioerror $
      Exception.try $
        initClock getExceptClock
          <&> first (hoistS (ioerror . Exception.try))
    where
      ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
      ioerror = liftEither <=< 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 handler) = do
    tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl1
    case tryToInit of
      Right (runningClock, initTime) -> do
        let catchingClock = safely $ do
              e <- AutomatonExcept.try runningClock
              let cl2 = handler e
              (runningClock', _) <- once_ $ initClock cl2
              safe $ runningClock' >>> arr (second Left)
        return (catchingClock, initTime)
      Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler 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 clsf1 clsf2 = readerS $ proc (timeInfo, a) -> do
  case tag timeInfo of
    Right tag1 -> runReaderS clsf1 -< (retag (const tag1) timeInfo, a)
    Left tag2 -> runReaderS clsf2 -< (retag (const tag2) timeInfo, 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 unhoistedClock =
  HoistClock
    { unhoistedClock
    , monadMorphism = fmap (either absurd id) . 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
  { singleTag :: tag
  -- ^ The tag that will be emitted on the tick.
  , getTime :: m time
  -- ^ A method to measure the current time.
  , 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 {singleTag, getTime, exception} = do
    initTime <- getTime
    let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
          step_ (initTime, singleTag)
          return exception
        errorT :: (MonadError e m) => m (Either e a) -> m a
        errorT = (>>= liftEither)
    return (runningClock, 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 cl handler mTime = CatchClock cl $ \e -> Single e mTime $ handler 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' cl = delayException cl 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 cl handler = delayException (ExceptClock cl) handler $ liftIO 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 = 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' cl = delayMonadIOError cl 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 = delayMonadIOException

-- | 'delayIOException'', but throw the error without transforming it.
delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
delayIOException' cl = delayIOException cl 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 = delayIOException

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