module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, destroyAlarmClock
, setAlarm
, setAlarmSTM
, setAlarmNow
, isAlarmSet
, isAlarmSetSTM
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (STM, atomically, retry, TVar, newTVar, writeTVar, readTVar, modifyTVar')
import Control.Concurrent.Timeout (timeout)
import Control.Exception (finally)
import Control.Monad (void)
import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
data AlarmClock = AlarmClock
{ acWaitForExit :: IO ()
, acNewSetting :: TVar AlarmSetting
, acIsSet :: TVar Bool
}
newAlarmClock
:: (AlarmClock -> IO ())
-> IO AlarmClock
newAlarmClock onWakeUp = do
joinVar <- atomically $ newTVar False
ac <- atomically $ AlarmClock (waitOn joinVar) <$> newTVar AlarmNotSet <*> newTVar False
void $ forkIO $ runAlarmClock ac (onWakeUp ac) `finally` atomically (writeTVar joinVar True)
return ac
waitOn :: TVar Bool -> IO ()
waitOn v = atomically $ readTVar v >>= \case True -> return (); False -> retry
destroyAlarmClock :: AlarmClock -> IO ()
destroyAlarmClock AlarmClock{..} = atomically (writeTVar acNewSetting AlarmDestroyed) >> acWaitForExit
setAlarm :: AlarmClock -> UTCTime -> IO ()
setAlarm ac t = atomically $ setAlarmSTM ac t
setAlarmSTM :: AlarmClock -> UTCTime -> STM ()
setAlarmSTM AlarmClock{..} t = modifyTVar' acNewSetting $ \case
AlarmDestroyed -> AlarmDestroyed
AlarmNotSet -> AlarmSet t
AlarmSet t' -> AlarmSet $! min t t'
setAlarmNow :: AlarmClock -> IO ()
setAlarmNow alarm = getCurrentTime >>= setAlarm alarm
isAlarmSet :: AlarmClock -> IO Bool
isAlarmSet = atomically . isAlarmSetSTM
isAlarmSetSTM :: AlarmClock -> STM Bool
isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting
>>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }
data AlarmSetting = AlarmNotSet | AlarmSet UTCTime | AlarmDestroyed
readNextAlarmSetting :: AlarmClock -> IO (Maybe UTCTime)
readNextAlarmSetting AlarmClock{..} = atomically $ readTVar acNewSetting >>= \case
AlarmNotSet -> retry
AlarmDestroyed -> return Nothing
AlarmSet t -> do
writeTVar acNewSetting AlarmNotSet
writeTVar acIsSet True
return $ Just t
runAlarmClock :: AlarmClock -> IO () -> IO ()
runAlarmClock ac wakeUpAction = loop
where
loop = readNextAlarmSetting ac >>= go
go Nothing = return ()
go (Just wakeUpTime) = wakeNoLaterThan wakeUpTime
wakeNoLaterThan wakeUpTime = do
dt <- diffUTCTime wakeUpTime <$> getCurrentTime
if dt <= 0
then actAndContinue
else timeout (ceiling $ 1000000 * dt)
(readNextAlarmSetting ac)
>>= \case
Nothing -> actAndContinue
Just newSetting -> go newSetting
actAndContinue = do
atomically $ writeTVar (acIsSet ac) False
wakeUpAction
loop