module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, destroyAlarmClock
, setAlarm
, setAlarmSTM
, setAlarmNow
, isAlarmSet
, isAlarmSetSTM
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO, newEmptyMVar, readMVar, putMVar)
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)
import GHC.Conc (labelThread, myThreadId)
data AlarmClock = AlarmClock
{ acWaitForExit :: IO ()
, acNewSetting :: TVar AlarmSetting
, acIsSet :: TVar Bool
}
newAlarmClock
:: (AlarmClock -> IO ())
-> IO AlarmClock
newAlarmClock onWakeUp = do
joinVar <- newEmptyMVar
ac <- atomically $ AlarmClock (readMVar joinVar) <$> newTVar AlarmNotSet <*> newTVar False
void $ forkIO $ runAlarmClock ac (onWakeUp ac) `finally` putMVar joinVar ()
return ac
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
labelMyThread :: String -> IO ()
labelMyThread threadLabel = myThreadId >>= flip labelThread threadLabel
runAlarmClock :: AlarmClock -> IO () -> IO ()
runAlarmClock AlarmClock{..} wakeUpAction = labelMyThread "alarmclock" >> loop
where
loop = readNextSetting >>= go
readNextSetting = atomically $ readTVar acNewSetting >>= \case
AlarmNotSet -> retry
AlarmDestroyed -> return Nothing
AlarmSet t -> do
writeTVar acNewSetting AlarmNotSet
writeTVar acIsSet True
return $ Just t
go Nothing = return ()
go (Just wakeUpTime) = wakeNoLaterThan wakeUpTime
wakeNoLaterThan wakeUpTime = do
dt <- ceiling <$> (1000000 *) <$> diffUTCTime wakeUpTime <$> getCurrentTime
if dt <= 0
then actAndContinue
else timeout dt readNextSetting >>= \case
Nothing -> actAndContinue
Just newSetting -> go newSetting
actAndContinue = do
atomically $ writeTVar acIsSet False
wakeUpAction
loop