module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, newAlarmClock'
, destroyAlarmClock
, withAlarmClock
, 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, bracket)
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 = newAlarmClock' $ const . onWakeUp
newAlarmClock'
:: (AlarmClock -> UTCTime -> 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
withAlarmClock :: (AlarmClock -> UTCTime -> IO ()) -> (AlarmClock -> IO a) -> IO a
withAlarmClock onWakeUp inner = bracket (newAlarmClock' onWakeUp) destroyAlarmClock inner
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 -> (UTCTime -> 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
currentTime <- getCurrentTime
let dt = ceiling $ (1000000 *) $ diffUTCTime wakeUpTime currentTime
safeTimeout dt readNextSetting >>= \case
Nothing -> actAndContinue currentTime
Just newSetting -> go newSetting
safeTimeout dt action
| dt > 0 = timeout dt action
| otherwise = return Nothing
actAndContinue currentTime = do
atomically $ writeTVar acIsSet False
wakeUpAction currentTime
loop