{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, newAlarmClock'
, destroyAlarmClock
, withAlarmClock
, setAlarm
, setAlarmSTM
, setAlarmNow
, isAlarmSet
, isAlarmSetSTM
, TimeScale
, MonotonicTime(..)
) where
import Control.Concurrent.Async (async, wait, waitSTM,
withAsync)
import Control.Concurrent.STM (STM, TVar, atomically,
modifyTVar',
newTVarIO, orElse,
readTVar, retry,
writeTVar)
import Control.Concurrent.Thread.Delay (delay)
import Control.Exception (bracket)
import Control.Monad (join)
import Control.Monad.Fix (mfix)
import GHC.Conc (labelThread,
myThreadId)
import Control.Concurrent.AlarmClock.TimeScale
data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed
data AlarmClock t = AlarmClock
{ AlarmClock t -> IO ()
acWaitForExit :: IO ()
, AlarmClock t -> TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
}
newAlarmClock
:: TimeScale t
=> (AlarmClock t -> IO ())
-> IO (AlarmClock t)
newAlarmClock :: (AlarmClock t -> IO ()) -> IO (AlarmClock t)
newAlarmClock AlarmClock t -> IO ()
onWakeUp = (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall t.
TimeScale t =>
(AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' ((AlarmClock t -> t -> IO ()) -> IO (AlarmClock t))
-> (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall a b. (a -> b) -> a -> b
$ IO () -> t -> IO ()
forall a b. a -> b -> a
const (IO () -> t -> IO ())
-> (AlarmClock t -> IO ()) -> AlarmClock t -> t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlarmClock t -> IO ()
onWakeUp
newAlarmClock'
:: TimeScale t
=> (AlarmClock t -> t -> IO ())
-> IO (AlarmClock t)
newAlarmClock' :: (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' AlarmClock t -> t -> IO ()
onWakeUp = (AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t))
-> (AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t)
forall a b. (a -> b) -> a -> b
$ \AlarmClock t
ac -> do
Async ()
acAsync <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ AlarmClock t -> (t -> IO ()) -> IO ()
forall t. TimeScale t => AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock AlarmClock t
ac (AlarmClock t -> t -> IO ()
onWakeUp AlarmClock t
ac)
IO () -> TVar (AlarmSetting t) -> AlarmClock t
forall t. IO () -> TVar (AlarmSetting t) -> AlarmClock t
AlarmClock (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
acAsync) (TVar (AlarmSetting t) -> AlarmClock t)
-> IO (TVar (AlarmSetting t)) -> IO (AlarmClock t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AlarmSetting t -> IO (TVar (AlarmSetting t))
forall a. a -> IO (TVar a)
newTVarIO AlarmSetting t
forall t. AlarmSetting t
AlarmNotSet
destroyAlarmClock :: AlarmClock t -> IO ()
destroyAlarmClock :: AlarmClock t -> IO ()
destroyAlarmClock AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} = STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (AlarmSetting t) -> AlarmSetting t -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (AlarmSetting t)
acNewSetting AlarmSetting t
forall t. AlarmSetting t
AlarmDestroyed) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
acWaitForExit
withAlarmClock :: TimeScale t
=> (AlarmClock t -> t -> IO ())
-> (AlarmClock t -> IO a) -> IO a
withAlarmClock :: (AlarmClock t -> t -> IO ()) -> (AlarmClock t -> IO a) -> IO a
withAlarmClock AlarmClock t -> t -> IO ()
onWakeUp AlarmClock t -> IO a
inner = IO (AlarmClock t)
-> (AlarmClock t -> IO ()) -> (AlarmClock t -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall t.
TimeScale t =>
(AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' AlarmClock t -> t -> IO ()
onWakeUp) AlarmClock t -> IO ()
forall t. AlarmClock t -> IO ()
destroyAlarmClock AlarmClock t -> IO a
inner
setAlarm :: TimeScale t => AlarmClock t -> t -> IO ()
setAlarm :: AlarmClock t -> t -> IO ()
setAlarm AlarmClock t
ac t
t = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AlarmClock t -> t -> STM ()
forall t. TimeScale t => AlarmClock t -> t -> STM ()
setAlarmSTM AlarmClock t
ac t
t
setAlarmSTM :: TimeScale t => AlarmClock t -> t -> STM ()
setAlarmSTM :: AlarmClock t -> t -> STM ()
setAlarmSTM AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} t
t = TVar (AlarmSetting t)
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (AlarmSetting t)
acNewSetting ((AlarmSetting t -> AlarmSetting t) -> STM ())
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
AlarmSetting t
AlarmNotSet -> t -> AlarmSetting t
forall t. t -> AlarmSetting t
AlarmSet t
t
AlarmSet t
t' -> t -> AlarmSetting t
forall t. t -> AlarmSetting t
AlarmSet (t -> AlarmSetting t) -> t -> AlarmSetting t
forall a b. (a -> b) -> a -> b
$! t -> t -> t
forall t. TimeScale t => t -> t -> t
earlierOf t
t t
t'
AlarmSetting t
AlarmDestroyed -> AlarmSetting t
forall t. AlarmSetting t
AlarmDestroyed
setAlarmNow :: TimeScale t => AlarmClock t -> IO ()
setAlarmNow :: AlarmClock t -> IO ()
setAlarmNow AlarmClock t
alarm = IO t
forall t. TimeScale t => IO t
getAbsoluteTime IO t -> (t -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AlarmClock t -> t -> IO ()
forall t. TimeScale t => AlarmClock t -> t -> IO ()
setAlarm AlarmClock t
alarm
isAlarmSet :: AlarmClock t -> IO Bool
isAlarmSet :: AlarmClock t -> IO Bool
isAlarmSet = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool)
-> (AlarmClock t -> STM Bool) -> AlarmClock t -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlarmClock t -> STM Bool
forall t. AlarmClock t -> STM Bool
isAlarmSetSTM
isAlarmSetSTM :: AlarmClock t -> STM Bool
isAlarmSetSTM :: AlarmClock t -> STM Bool
isAlarmSetSTM AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} = TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting
STM (AlarmSetting t) -> (AlarmSetting t -> STM Bool) -> STM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case { AlarmSet t
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True; AlarmSetting t
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False }
labelMyThread :: String -> IO ()
labelMyThread :: String -> IO ()
labelMyThread String
threadLabel = IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ThreadId -> String -> IO ()) -> String -> ThreadId -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> String -> IO ()
labelThread String
threadLabel
runAlarmClock :: TimeScale t => AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock :: AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} t -> IO ()
wakeUpAction = String -> IO ()
labelMyThread String
"alarmclock" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
where
loop :: IO ()
loop :: IO ()
loop = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically STM (IO ())
whenNotSet
whenNotSet :: STM (IO ())
whenNotSet :: STM (IO ())
whenNotSet = TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting STM (AlarmSetting t)
-> (AlarmSetting t -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
AlarmSetting t
AlarmNotSet -> STM (IO ())
forall a. STM a
retry
AlarmSetting t
AlarmDestroyed -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
AlarmSet t
wakeUpTime -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ t -> IO ()
whenSet t
wakeUpTime
whenSet :: t -> IO ()
whenSet t
wakeUpTime = do
t
now <- IO t
forall t. TimeScale t => IO t
getAbsoluteTime
let microsecondsTimeout :: Integer
microsecondsTimeout = t -> t -> Integer
forall t. TimeScale t => t -> t -> Integer
microsecondsDiff t
wakeUpTime t
now
if Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
microsecondsTimeout
then IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Async () -> IO (IO ())) -> IO (IO ())
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Integer -> IO ()
delay Integer
microsecondsTimeout) ((Async () -> IO (IO ())) -> IO (IO ()))
-> (Async () -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Async ()
a -> STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
(Async () -> STM ()
forall a. Async a -> STM a
waitSTM Async ()
a STM () -> STM (IO ()) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> IO ()
whenSet t
wakeUpTime))
STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
`orElse`
(TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting STM (AlarmSetting t)
-> (AlarmSetting t -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
AlarmSet t
wakeUpTime' | t -> t -> t
forall t. TimeScale t => t -> t -> t
earlierOf t
wakeUpTime' t
wakeUpTime t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
wakeUpTime -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ t -> IO ()
whenSet t
wakeUpTime'
AlarmSetting t
AlarmDestroyed -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
AlarmSetting t
_ -> STM (IO ())
forall a. STM a
retry
)
else do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (AlarmSetting t)
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (AlarmSetting t)
acNewSetting ((AlarmSetting t -> AlarmSetting t) -> STM ())
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
AlarmSet t
_ -> AlarmSetting t
forall t. AlarmSetting t
AlarmNotSet
AlarmSetting t
setting -> AlarmSetting t
setting
t -> IO ()
wakeUpAction t
now
IO ()
loop