module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, destroyAlarmClock
, setAlarm
, setAlarmSTM
, setAlarmNow
, isAlarmSet
, isAlarmSetSTM
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Time
import System.Timeout
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 (fromIntegral $ min maxDelay $ ceiling $ 1000000 * dt)
(readNextAlarmSetting ac)
>>= \case
Nothing -> do
t' <- getCurrentTime
if t' < wakeUpTime
then wakeNoLaterThan wakeUpTime
else actAndContinue
Just newSetting -> go newSetting
actAndContinue = do
atomically $ writeTVar (acIsSet ac) False
wakeUpAction
loop
maxDelay :: Integer
maxDelay = fromIntegral (maxBound :: Int)