{-# options_haddock prune #-}

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

import qualified Control.Exception as Base
import Polysemy.Scoped (interpretScopedH, runScopedAs)
import qualified Polysemy.Time as Time
import Polysemy.Time (Time)

import Polysemy.Conc.Async (withAsync_)
import Polysemy.Conc.Effect.Monitor (
  Monitor (Monitor),
  MonitorCheck (MonitorCheck),
  RestartingMonitor,
  ScopedMonitor,
  hoistMonitorCheck,
  )
import qualified Polysemy.Conc.Effect.Race as Race
import Polysemy.Conc.Effect.Race (Race)

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)

monitorRestart ::
  ∀ t d r a .
  Members [Time t d, Resource, Async, Race, Final IO] r =>
  MonitorCheck r ->
  (CancelResource -> Sem r a) ->
  Sem r a
monitorRestart :: forall t d (r :: EffectRow) a.
Members '[Time t d, Resource, Async, Race, Final IO] r =>
MonitorCheck r -> (CancelResource -> Sem r a) -> Sem r a
monitorRestart (MonitorCheck NanoSeconds
interval MVar () -> Sem r ()
check) CancelResource -> Sem r a
use = do
  MVar ()
sig <- forall (m :: * -> *) (r :: EffectRow) 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 :: EffectRow) b a.
Members '[Resource, Race, Async] r =>
Sem r b -> Sem r a -> Sem r a
withAsync_ (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 :: CancelResource
res = (MVar () -> CancelResource
CancelResource MVar ()
sig)
      Sem r (Maybe ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) (r :: EffectRow) 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 :: EffectRow) a.
Member (Final IO) r =>
Sem (Error e : r) a -> Sem r (Either e a)
errorToIOFinal @MonitorCancel (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 :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (CancelResource -> Sem r a
use 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 r
interpretMonitorRestart :: forall t d (r :: EffectRow).
Members '[Time t d, Resource, Async, Race, Final IO] r =>
MonitorCheck r -> InterpreterFor RestartingMonitor r
interpretMonitorRestart MonitorCheck r
check =
  (forall (q :: (* -> *) -> * -> *) x.
 ()
 -> (CancelResource -> Sem (Opaque q : r) x)
 -> Sem (Opaque q : r) x)
-> (forall (q :: (* -> *) -> * -> *) (r0 :: EffectRow) x.
    CancelResource
    -> Monitor Restart (Sem r0) x
    -> Tactical (Monitor Restart) (Sem r0) (Opaque q : r) x)
-> InterpreterFor RestartingMonitor r
forall resource param (effect :: (* -> *) -> * -> *)
       (r :: EffectRow).
(forall (q :: (* -> *) -> * -> *) x.
 param
 -> (resource -> Sem (Opaque q : r) x) -> Sem (Opaque q : r) x)
-> (forall (q :: (* -> *) -> * -> *) (r0 :: EffectRow) x.
    resource
    -> effect (Sem r0) x -> Tactical effect (Sem r0) (Opaque q : r) x)
-> InterpreterFor (Scoped param effect) r
interpretScopedH (((CancelResource -> Sem (Opaque q : r) x) -> Sem (Opaque q : r) x)
-> ()
-> (CancelResource -> Sem (Opaque q : r) x)
-> Sem (Opaque q : r) x
forall a b. a -> b -> a
const (forall t d (r :: EffectRow) a.
Members '[Time t d, Resource, Async, Race, Final IO] r =>
MonitorCheck r -> (CancelResource -> Sem r a) -> Sem r a
monitorRestart @t @d ((forall x. Sem r x -> Sem (Opaque q : r) x)
-> MonitorCheck r -> MonitorCheck (Opaque q : r)
forall (r :: EffectRow) (r' :: EffectRow).
(forall x. Sem r x -> Sem r' x)
-> MonitorCheck r -> MonitorCheck r'
hoistMonitorCheck forall x. Sem r x -> Sem (Opaque q : r) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise MonitorCheck r
check))) \ CancelResource {MVar ()
signal :: MVar ()
$sel:signal:CancelResource :: CancelResource -> MVar ()
..} -> \case
    Monitor Sem r0 x
ma ->
      (()
 -> Sem
      (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x))
-> (f x
    -> Sem
         (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x))
-> Either () (f x)
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Sem (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
-> ()
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
forall a b. a -> b -> a
const (MonitorCancel
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
forall a e. Exception e => e -> a
Base.throw MonitorCancel
MonitorCancel)) f x
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (f x)
 -> Sem
      (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x))
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r))
     (Either () (f x))
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) ()
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : r)) (f x)
-> Sem
     (WithTactics (Monitor Restart) f (Sem r0) (Opaque q : 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 (forall (m :: * -> *) (r :: EffectRow) 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 r0 x -> Tactical (Monitor Restart) (Sem r0) (Opaque q : r) x
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem r0 x
ma)

interpretMonitorPure' :: () -> InterpreterFor (Monitor action) r
interpretMonitorPure' :: forall action (r :: EffectRow).
() -> InterpreterFor (Monitor action) r
interpretMonitorPure' ()
_ =
  (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 :: (* -> *) -> * -> *) (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 Sem rInitial x
ma ->
      Sem rInitial x -> Tactical (Monitor action) (Sem rInitial) r x
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (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 :: forall action (r :: EffectRow).
InterpreterFor (ScopedMonitor action) r
interpretMonitorPure =
  (() -> Sem r ())
-> (forall (q :: (* -> *) -> * -> *).
    () -> InterpreterFor (Monitor action) (Opaque q : r))
-> InterpreterFor (Scoped () (Monitor action)) r
forall resource param (effect :: (* -> *) -> * -> *)
       (r :: EffectRow).
(param -> Sem r resource)
-> (forall (q :: (* -> *) -> * -> *).
    resource -> InterpreterFor effect (Opaque q : r))
-> InterpreterFor (Scoped param effect) r
runScopedAs (Sem r () -> () -> Sem r ()
forall a b. a -> b -> a
const Sem r ()
forall (f :: * -> *). Applicative f => f ()
unit) forall action (r :: EffectRow).
() -> InterpreterFor (Monitor action) r
forall (q :: (* -> *) -> * -> *).
() -> InterpreterFor (Monitor action) (Opaque q : r)
interpretMonitorPure'