module Control.Eff.Concurrent.Process.Timer
( Timeout(fromTimeoutMicros)
, TimerReference()
, TimerElapsed(fromTimerElapsed)
, sendAfter
, startTimer
, cancelTimer
, selectTimerElapsed
, receiveAfter
, receiveSelectedAfter
, receiveSelectedWithMonitorAfter
)
where
import Control.Eff.Concurrent.Process
import Control.Concurrent
import Control.Eff
import Control.DeepSeq
import Control.Monad.IO.Class
import Data.Typeable
import Control.Applicative
import GHC.Stack
receiveAfter
:: forall a r q
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
, 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
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
, Show a
)
=> MessageSelector a
-> Timeout
-> Eff r (Either TimerElapsed a)
receiveSelectedAfter sel t = do
timerRef <- startTimer t
res <- receiveSelectedMessage
(Left <$> selectTimerElapsed timerRef <|> Right <$> sel)
cancelTimer timerRef
return res
receiveSelectedWithMonitorAfter
:: forall a r q
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
, Show a
)
=> ProcessId
-> MessageSelector a
-> Timeout
-> Eff r (Either (Either ProcessDown TimerElapsed) a)
receiveSelectedWithMonitorAfter pid sel t = do
timerRef <- startTimer 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 Timeout = TimeoutMicros {fromTimeoutMicros :: Int}
deriving (NFData, Ord,Eq, Num, Integral, Real, Enum, Typeable)
instance Show Timeout where
showsPrec d (TimeoutMicros t) =
showParen (d >= 10) (showString "timeout: " . shows t . showString " µs")
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
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
, Typeable message
, NFData message
)
=> ProcessId
-> Timeout
-> (TimerReference -> message)
-> Eff r TimerReference
sendAfter pid (TimeoutMicros 0) mkMsg = TimerReference <$> spawn
(yieldProcess >> self >>= (sendMessage pid . force . mkMsg . TimerReference))
sendAfter pid (TimeoutMicros t) mkMsg = TimerReference <$> spawn
( liftIO (threadDelay t)
>> self
>>= (sendMessage pid . force . mkMsg . TimerReference)
)
startTimer
:: forall r q
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
)
=> Timeout
-> Eff r TimerReference
startTimer t = do
p <- self
sendAfter p t TimerElapsed
cancelTimer
:: forall r q
. ( Lifted IO q
, HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
)
=> TimerReference
-> Eff r ()
cancelTimer (TimerReference tr) = sendShutdown tr ExitNormally