{-# options_haddock prune #-}

-- |Description: Monitor Interpreters, Internal
module Polysemy.Conc.Interpreter.Monitor where

import qualified Control.Exception as Base
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 stock (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)
  deriving anyclass (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
Exception)

interpretMonitorCancel ::
  Members [Race, Async, Final IO] r =>
  MonitorResource CancelResource ->
  InterpreterFor (Monitor action) r
interpretMonitorCancel :: forall (r :: [(* -> *) -> * -> *]) action.
Members '[Race, Async, Final IO] r =>
MonitorResource CancelResource -> InterpreterFor (Monitor action) r
interpretMonitorCancel (MonitorResource CancelResource {MVar ()
signal :: MVar ()
$sel:signal:CancelResource :: CancelResource -> MVar ()
..}) =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Monitor action (Sem rInitial) x
 -> Tactical (Monitor action) (Sem rInitial) r x)
-> Sem (Monitor action : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Monitor Sem rInitial x
ma ->
      (() -> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x))
-> (f x
    -> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x))
-> Either () (f x)
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
-> ()
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall a b. a -> b -> a
const (MonitorCancel
-> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall a e. Exception e => e -> a
Base.throw MonitorCancel
MonitorCancel)) f x -> Sem (WithTactics (Monitor action) f (Sem rInitial) r) (f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: [(* -> *) -> * -> *]).
Member Race r =>
Sem r a -> Sem r b -> Sem r (Either a b)
Race.race (forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO (MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
signal)) (Sem rInitial x -> Tactical (Monitor action) (Sem rInitial) r x
forall (m :: * -> *) a (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]).
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 :: forall 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 NanoSeconds
interval MVar () -> Sem r ()
check) MonitorResource CancelResource -> Sem r a
use = do
  MVar ()
sig <- forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  Sem r () -> Sem r a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) b a.
Members '[Resource, Race, Async] r =>
Sem r b -> Sem r a -> Sem r a
withAsync_ (forall t d u (r :: [(* -> *) -> * -> *]).
(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 (forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal @IO (MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
sig))
      (MonitorCancel -> Sem r a)
-> (a -> Sem r a) -> Either MonitorCancel a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Sem r a -> MonitorCancel -> Sem r a
forall a b. a -> b -> a
const (MVar () -> Sem r a
spin MVar ()
sig)) a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
=<< forall e (r :: [(* -> *) -> * -> *]) a.
(Typeable e, Member (Final IO) r) =>
Sem (Error e : r) a -> Sem r (Either e a)
errorToIOFinal @MonitorCancel (forall e (r :: [(* -> *) -> * -> *]) 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 :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (MonitorResource CancelResource -> Sem r a
use 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 :: forall t d (r :: [(* -> *) -> * -> *]).
Members '[Time t d, Resource, Async, Race, Final IO] r =>
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 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]).
(forall x. (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScoped (forall 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 @t @d MonitorCheck r
check) MonitorResource CancelResource
-> InterpreterFor (Monitor Restart) r
forall (r :: [(* -> *) -> * -> *]) action.
Members '[Race, Async, Final IO] r =>
MonitorResource CancelResource -> InterpreterFor (Monitor action) r
interpretMonitorCancel

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

-- |Run 'Monitor' as a no-op.
interpretMonitorPure :: InterpreterFor (ScopedMonitor () action) r
interpretMonitorPure :: forall action (r :: [(* -> *) -> * -> *]).
InterpreterFor (ScopedMonitor () action) r
interpretMonitorPure =
  Sem r (MonitorResource ())
-> (MonitorResource () -> InterpreterFor (Monitor action) r)
-> InterpreterFor (Scoped (MonitorResource ()) (Monitor action)) r
forall resource (effect :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]).
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 :: [(* -> *) -> * -> *]).
MonitorResource () -> InterpreterFor (Monitor action) r
interpretMonitorPure'