{-# options_haddock prune #-}
-- |Description: Monitor Interpreters, Internal
module Polysemy.Conc.Interpreter.Monitor where

import qualified Control.Exception as Base
import Polysemy (embedFinal, runTSimple)
import Polysemy.Async (Async)
import Polysemy.Error (errorToIOFinal, fromExceptionSem)
import Polysemy.Resource (Resource)
import qualified Polysemy.Time as Time
import Polysemy.Time (Time)

import Polysemy.Conc.Async (withAsync_)
import Polysemy.Conc.Effect.Monitor (
  Monitor (Monitor),
  MonitorCheck (MonitorCheck),
  MonitorResource (MonitorResource),
  RestartingMonitor,
  ScopedMonitor,
  )
import qualified Polysemy.Conc.Effect.Race as Race
import Polysemy.Conc.Effect.Race (Race)
import Polysemy.Conc.Interpreter.Scoped (runScoped, runScopedAs)

newtype CancelResource =
  CancelResource { CancelResource -> MVar ()
signal :: MVar () }

data MonitorCancel =
  MonitorCancel
  deriving (MonitorCancel -> MonitorCancel -> Bool
(MonitorCancel -> MonitorCancel -> Bool)
-> (MonitorCancel -> MonitorCancel -> Bool) -> Eq MonitorCancel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MonitorCancel -> MonitorCancel -> Bool
$c/= :: MonitorCancel -> MonitorCancel -> Bool
== :: MonitorCancel -> MonitorCancel -> Bool
$c== :: MonitorCancel -> MonitorCancel -> Bool
Eq, Int -> MonitorCancel -> ShowS
[MonitorCancel] -> ShowS
MonitorCancel -> String
(Int -> MonitorCancel -> ShowS)
-> (MonitorCancel -> String)
-> ([MonitorCancel] -> ShowS)
-> Show MonitorCancel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MonitorCancel] -> ShowS
$cshowList :: [MonitorCancel] -> ShowS
show :: MonitorCancel -> String
$cshow :: MonitorCancel -> String
showsPrec :: Int -> MonitorCancel -> ShowS
$cshowsPrec :: Int -> MonitorCancel -> ShowS
Show, Show MonitorCancel
Typeable MonitorCancel
Typeable MonitorCancel
-> Show MonitorCancel
-> (MonitorCancel -> SomeException)
-> (SomeException -> Maybe MonitorCancel)
-> (MonitorCancel -> String)
-> Exception MonitorCancel
SomeException -> Maybe MonitorCancel
MonitorCancel -> String
MonitorCancel -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: MonitorCancel -> String
$cdisplayException :: MonitorCancel -> String
fromException :: SomeException -> Maybe MonitorCancel
$cfromException :: SomeException -> Maybe MonitorCancel
toException :: MonitorCancel -> SomeException
$ctoException :: MonitorCancel -> SomeException
$cp2Exception :: Show MonitorCancel
$cp1Exception :: Typeable MonitorCancel
Exception)

interpretMonitorCancel ::
  Members [Race, Async, Final IO] r =>
  MonitorResource CancelResource ->
  InterpreterFor (Monitor action) r
interpretMonitorCancel :: MonitorResource CancelResource -> InterpreterFor (Monitor action) r
interpretMonitorCancel (MonitorResource CancelResource {MVar ()
signal :: MVar ()
$sel:signal:CancelResource :: CancelResource -> MVar ()
..}) =
  (forall (rInitial :: EffectRow) x.
 Monitor action (Sem rInitial) x
 -> Tactical (Monitor action) (Sem rInitial) r x)
-> Sem (Monitor action : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Monitor ma ->
      Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
-> Either () (f x)
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall (m :: * -> *) b a. Applicative m => m b -> Either a b -> m b
leftM (MonitorCancel
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall a e. Exception e => e -> a
Base.throw MonitorCancel
MonitorCancel) (Either () (f x)
 -> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x))
-> Sem
     (WithTactics (Monitor action) f (Sem rInitial) r) (Either () (f x))
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (WithTactics (Monitor action) f (Sem rInitial) r) ()
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
-> Sem
     (WithTactics (Monitor action) f (Sem rInitial) r) (Either () (f x))
forall a b (r :: EffectRow).
Member Race r =>
Sem r a -> Sem r b -> Sem r (Either a b)
Race.race (IO () -> Sem (WithTactics (Monitor action) f (Sem rInitial) r) ()
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO (MVar () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ()
signal)) (Sem rInitial x -> Tactical (Monitor action) (Sem rInitial) r x
forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem rInitial x
ma)

monitorRestart ::
  ∀ t d r a .
  Members [Time t d, Resource, Async, Race, Final IO] r =>
  MonitorCheck r ->
  (MonitorResource CancelResource -> Sem r a) ->
  Sem r a
monitorRestart :: MonitorCheck r
-> (MonitorResource CancelResource -> Sem r a) -> Sem r a
monitorRestart (MonitorCheck NanoSeconds
interval MVar () -> Sem r ()
check) MonitorResource CancelResource -> Sem r a
run = do
  MVar ()
sig <- IO (MVar ()) -> Sem r (MVar ())
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  Sem r () -> Sem r a -> Sem r a
forall (r :: EffectRow) b a.
Members '[Resource, Race, Async] r =>
Sem r b -> Sem r a -> Sem r a
withAsync_ (NanoSeconds -> Sem r () -> Sem r ()
forall t d u (r :: EffectRow).
(Member (Time t d) r, TimeUnit u) =>
u -> Sem r () -> Sem r ()
Time.loop_ @t @d NanoSeconds
interval (MVar () -> Sem r ()
check MVar ()
sig)) (MVar () -> Sem r a
spin MVar ()
sig)
  where
    spin :: MVar () -> Sem r a
spin MVar ()
sig = do
      let res :: MonitorResource CancelResource
res = (CancelResource -> MonitorResource CancelResource
forall a. a -> MonitorResource a
MonitorResource (MVar () -> CancelResource
CancelResource MVar ()
sig))
      Sem r (Maybe ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> Sem r (Maybe ())
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO (MVar () -> IO (Maybe ())
forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
tryTakeMVar MVar ()
sig))
      Sem r a -> Either MonitorCancel a -> Sem r a
forall (m :: * -> *) b a. Applicative m => m b -> Either a b -> m b
leftM (MVar () -> Sem r a
spin MVar ()
sig) (Either MonitorCancel a -> Sem r a)
-> Sem r (Either MonitorCancel a) -> Sem r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (Error MonitorCancel : r) a -> Sem r (Either MonitorCancel a)
forall e (r :: EffectRow) a.
(Typeable e, Member (Final IO) r) =>
Sem (Error e : r) a -> Sem r (Either e a)
errorToIOFinal @MonitorCancel (Sem (Error MonitorCancel : r) a -> Sem (Error MonitorCancel : r) a
forall e (r :: EffectRow) a.
(Exception e, Member (Error e) r, Member (Final IO) r) =>
Sem r a -> Sem r a
fromExceptionSem @MonitorCancel (Sem r a -> Sem (Error MonitorCancel : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise (MonitorResource CancelResource -> Sem r a
run MonitorResource CancelResource
res)))

-- |Interpret @'Polysemy.Conc.Scoped' 'Monitor'@ with the 'Polysemy.Conc.Restart' strategy.
-- This takes a check action that may put an 'MVar' when the scoped region should be restarted.
-- The check is executed in a loop, with an interval given in 'MonitorCheck'.
interpretMonitorRestart ::
  ∀ t d r .
  Members [Time t d, Resource, Async, Race, Final IO] r =>
  MonitorCheck r ->
  InterpreterFor (RestartingMonitor CancelResource) r
interpretMonitorRestart :: MonitorCheck r
-> InterpreterFor (RestartingMonitor CancelResource) r
interpretMonitorRestart MonitorCheck r
check =
  (forall x. (MonitorResource CancelResource -> Sem r x) -> Sem r x)
-> (MonitorResource CancelResource
    -> InterpreterFor (Monitor Restart) r)
-> InterpreterFor (RestartingMonitor CancelResource) r
forall resource (effect :: Effect) (r :: EffectRow).
(forall x. (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScoped (MonitorCheck r
-> (MonitorResource CancelResource -> Sem r x) -> Sem r x
forall t d (r :: EffectRow) a.
Members '[Time t d, Resource, Async, Race, Final IO] r =>
MonitorCheck r
-> (MonitorResource CancelResource -> Sem r a) -> Sem r a
monitorRestart @t @d MonitorCheck r
check) MonitorResource CancelResource
-> InterpreterFor (Monitor Restart) r
forall (r :: EffectRow) action.
Members '[Race, Async, Final IO] r =>
MonitorResource CancelResource -> InterpreterFor (Monitor action) r
interpretMonitorCancel

interpretMonitorPure' :: MonitorResource () -> InterpreterFor (Monitor action) r
interpretMonitorPure' :: MonitorResource () -> InterpreterFor (Monitor action) r
interpretMonitorPure' MonitorResource ()
_ =
  (forall (rInitial :: EffectRow) x.
 Monitor action (Sem rInitial) x
 -> Tactical (Monitor action) (Sem rInitial) r x)
-> Sem (Monitor action : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Monitor ma ->
      Sem rInitial x -> Tactical (Monitor action) (Sem rInitial) r x
forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem rInitial x
ma

-- |Run 'Monitor' as a no-op.
interpretMonitorPure :: InterpreterFor (ScopedMonitor () action) r
interpretMonitorPure :: Sem (ScopedMonitor () action : r) a -> Sem r a
interpretMonitorPure =
  Sem r (MonitorResource ())
-> (MonitorResource () -> InterpreterFor (Monitor action) r)
-> InterpreterFor (ScopedMonitor () action) r
forall resource (effect :: Effect) (r :: EffectRow).
Sem r resource
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScopedAs (MonitorResource () -> Sem r (MonitorResource ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> MonitorResource ()
forall a. a -> MonitorResource a
MonitorResource ())) MonitorResource () -> InterpreterFor (Monitor action) r
forall action (r :: EffectRow).
MonitorResource () -> InterpreterFor (Monitor action) r
interpretMonitorPure'