module Util.Delayer(
Delayer,
newDelayer,
HasDelayer(..),
delay,
DelayedAction,
newDelayedAction,
delayedAct,
cancelDelayedAct,
HasAddDelayer(..),
HasAddDelayerIO(..),
) where
import Control.Concurrent.MVar
import Control.Exception
import qualified Data.Set as Set
import Util.Object
import Util.Computation(done)
data DelayedAction = DelayedAction {
oId :: ObjectID,
action :: IO ()
}
data DelayerState = DelayerState {
delayCount :: ! Int,
delayedActions :: Set.Set DelayedAction
}
data Delayer = Delayer (MVar DelayerState)
class HasAddDelayer eventSource where
addDelayer :: Delayer -> eventSource -> eventSource
class HasAddDelayerIO eventSource where
addDelayerIO :: Delayer -> eventSource -> IO eventSource
class HasDelayer object where
toDelayer :: object -> Delayer
instance Eq DelayedAction where
(==) act1 act2 = (==) (oId act1) (oId act2)
instance Ord DelayedAction where
compare act1 act2 = compare (oId act1) (oId act2)
instance HasDelayer Delayer where
toDelayer delayer = delayer
newDelayer :: IO Delayer
newDelayer =
do
mVar <- newMVar emptyDelayerState
return (Delayer mVar)
delay :: HasDelayer object => object -> IO a -> IO a
delay object action =
do
let
delayer = toDelayer object
beginDelay delayer
finally action (endDelay delayer)
beginDelay :: Delayer -> IO ()
beginDelay (Delayer mVar) =
modifyMVar_ mVar (\ delayerState0 ->
do
let
delayCount1 = delayCount delayerState0 + 1
delayerState1 = delayerState0 {delayCount = delayCount1}
seq delayerState1 (return delayerState1)
)
endDelay :: Delayer -> IO ()
endDelay (Delayer mVar) =
do
afterAct <- modifyMVar mVar (\ delayerState0 ->
do
let
delayCount1 = delayCount delayerState0 1
return (if delayCount1 > 0
then
(delayerState0 {delayCount = delayCount1},done)
else
let
afterAct = mapM_
(\ delayedAction -> action delayedAction)
(Set.toList (delayedActions delayerState0))
in
(emptyDelayerState,afterAct)
)
)
afterAct
emptyDelayerState :: DelayerState
emptyDelayerState = DelayerState {
delayCount = 0,
delayedActions = Set.empty
}
newDelayedAction :: IO () -> IO DelayedAction
newDelayedAction action =
do
oId <- newObject
let
delayedAction = DelayedAction {
oId = oId,
action = action
}
return delayedAction
delayedAct :: Delayer -> DelayedAction -> IO ()
delayedAct (Delayer mVar) delayedAct =
do
afterAct <- modifyMVar mVar (\ delayerState0 ->
return (
if delayCount delayerState0 == 0
then
(delayerState0,action delayedAct)
else
let
delayedActions1 = Set.insert delayedAct
(delayedActions delayerState0)
delayerState1 = delayerState0 {
delayedActions = delayedActions1
}
in
(delayerState1,done)
)
)
afterAct
cancelDelayedAct :: Delayer -> DelayedAction -> IO ()
cancelDelayedAct (Delayer mVar) delayedAction =
modifyMVar_ mVar (\ delayerState0 ->
let
delayedActions1
= Set.delete delayedAction (delayedActions delayerState0)
delayerState1 = delayerState0 {delayedActions = delayedActions1}
in
return delayerState1
)