module Control.Eff.Concurrent.Process.Timer
( TimerReference()
, TimerElapsed(fromTimerElapsed)
, sendAfter
, startTimer
, sendAfterWithTitle
, startTimerWithTitle
, cancelTimer
, selectTimerElapsed
, receiveAfter
, receiveSelectedAfter
, receiveSelectedWithMonitorAfter
, receiveAfterWithTitle
, receiveSelectedAfterWithTitle
, receiveSelectedWithMonitorAfterWithTitle
)
where
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Misc
import Control.Eff
import Control.DeepSeq
import Data.Typeable
import Data.Text as T
import Control.Applicative
import GHC.Stack
receiveAfter
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Typeable a
, NFData a
, Show a
)
=> Timeout
-> Eff r (Maybe a)
receiveAfter t =
either (const Nothing) Just <$> receiveSelectedAfter (selectMessage @a) t
receiveSelectedAfter
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Show a
, Typeable a
)
=> MessageSelector a
-> Timeout
-> Eff r (Either TimerElapsed a)
receiveSelectedAfter sel t = do
let timerTitle =
MkProcessTitle
("receive-timer-"
<> pack (showSTypeable @a "")
<> "-"
<> pack (show t)
)
timerRef <- startTimerWithTitle timerTitle t
res <- receiveSelectedMessage
(Left <$> selectTimerElapsed timerRef <|> Right <$> sel)
cancelTimer timerRef
return res
receiveSelectedWithMonitorAfter
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Show a
, Typeable a
)
=> ProcessId
-> MessageSelector a
-> Timeout
-> Eff r (Either (Either ProcessDown TimerElapsed) a)
receiveSelectedWithMonitorAfter pid sel t =
let timerTitle =
MkProcessTitle
("receive-timer-"
<> pack (showSTypeable @a "")
<> "-monitoring-"
<> pack (show pid)
<> "-"
<> pack (show t)
)
in receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle
receiveAfterWithTitle
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Typeable a
, NFData a
, Show a
)
=> Timeout
-> ProcessTitle
-> Eff r (Maybe a)
receiveAfterWithTitle t timerTitle =
either (const Nothing) Just <$> receiveSelectedAfterWithTitle (selectMessage @a) t timerTitle
receiveSelectedAfterWithTitle
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Show a
, Typeable a
)
=> MessageSelector a
-> Timeout
-> ProcessTitle
-> Eff r (Either TimerElapsed a)
receiveSelectedAfterWithTitle sel t timerTitle = do
timerRef <- startTimerWithTitle timerTitle t
res <- receiveSelectedMessage
(Left <$> selectTimerElapsed timerRef <|> Right <$> sel)
cancelTimer timerRef
return res
receiveSelectedWithMonitorAfterWithTitle
:: forall a r q
. ( HasCallStack
, HasProcesses r q
, Show a
, Typeable a
)
=> ProcessId
-> MessageSelector a
-> Timeout
-> ProcessTitle
-> Eff r (Either (Either ProcessDown TimerElapsed) a)
receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle = do
timerRef <- startTimerWithTitle timerTitle t
res <- withMonitor pid $ \pidMon -> do
receiveSelectedMessage
( Left . Left <$> selectProcessDown pidMon
<|> Left . Right <$> selectTimerElapsed timerRef
<|> Right <$> sel
)
cancelTimer timerRef
return res
selectTimerElapsed :: TimerReference -> MessageSelector TimerElapsed
selectTimerElapsed timerRef =
filterMessage (\(TimerElapsed timerRefIn) -> timerRef == timerRefIn)
newtype TimerReference = TimerReference ProcessId
deriving (NFData, Ord,Eq, Num, Integral, Real, Enum, Typeable)
instance Show TimerReference where
showsPrec d (TimerReference t) =
showParen (d >= 10) (showString "timer: " . shows t)
newtype TimerElapsed = TimerElapsed {fromTimerElapsed :: TimerReference}
deriving (NFData, Ord,Eq, Typeable)
instance Show TimerElapsed where
showsPrec d (TimerElapsed t) =
showParen (d >= 10) (shows t . showString " elapsed")
sendAfter
:: forall r q message
. ( HasCallStack
, HasProcesses r q
, Typeable message
, NFData message
)
=> ProcessId
-> Timeout
-> (TimerReference -> message)
-> Eff r TimerReference
sendAfter pid t mkMsg =
sendAfterWithTitle
(MkProcessTitle ("send-after-timer-" <> T.pack (show t) <> "-" <> T.pack (showSTypeable @message "") <> "-" <> T.pack (show pid)))
pid
t
mkMsg
sendAfterWithTitle
:: forall r q message
. ( HasCallStack
, HasProcesses r q
, Typeable message
, NFData message
)
=> ProcessTitle
-> ProcessId
-> Timeout
-> (TimerReference -> message)
-> Eff r TimerReference
sendAfterWithTitle title pid t mkMsg =
TimerReference <$>
(spawn
title
(delay t
>> self
>>= (sendMessage pid . force . mkMsg . TimerReference)))
startTimerWithTitle
:: forall r q
. ( HasCallStack
, HasProcesses r q
)
=> ProcessTitle
-> Timeout
-> Eff r TimerReference
startTimerWithTitle title t = do
p <- self
sendAfterWithTitle title p t TimerElapsed
startTimer
:: forall r q
. ( HasCallStack
, HasProcesses r q
)
=> Timeout
-> Eff r TimerReference
startTimer t = do
p <- self
sendAfter p t TimerElapsed
cancelTimer
:: forall r q
. ( HasCallStack
, HasProcesses r q
)
=> TimerReference
-> Eff r ()
cancelTimer (TimerReference tr) = sendShutdown tr ExitNormally