module Control.Concurrent.AlarmClock
( AlarmClock()
, newAlarmClock
, newAlarmClock'
, destroyAlarmClock
, withAlarmClock
, setAlarm
, setAlarmSTM
, setAlarmNow
, isAlarmSet
, isAlarmSetSTM
, TimeScale(..)
, MonotonicTime(..)
) where
import Control.Concurrent.Async (async, wait)
import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar',
newTVarIO, readTVar, retry,
writeTVar)
import Control.Concurrent.Timeout (timeout)
import Control.Exception (bracket)
import Control.Monad.Fix (mfix)
import Data.Time (UTCTime, diffUTCTime,
getCurrentTime)
import GHC.Conc (labelThread, myThreadId)
import System.Clock (Clock (Monotonic), TimeSpec,
diffTimeSpec, getTime,
timeSpecAsNanoSecs)
class TimeScale t where
getAbsoluteTime :: IO t
microsecondsDiff :: t -> t -> Integer
earlierOf :: t -> t -> t
instance TimeScale UTCTime where
getAbsoluteTime = getCurrentTime
earlierOf = min
microsecondsDiff t1 t2 = ceiling $ (1000000 *) $ diffUTCTime t1 t2
newtype MonotonicTime = MonotonicTime TimeSpec deriving (Show, Eq, Ord)
instance TimeScale MonotonicTime where
getAbsoluteTime = MonotonicTime <$> getTime Monotonic
earlierOf = min
microsecondsDiff (MonotonicTime t1) (MonotonicTime t2)
= (`div` 1000) $ timeSpecAsNanoSecs $ diffTimeSpec t1 t2
data AlarmClock t = AlarmClock
{ acWaitForExit :: IO ()
, acNewSetting :: TVar (AlarmSetting t)
, acIsSet :: TVar Bool
}
newAlarmClock
:: TimeScale t
=> (AlarmClock t -> IO ())
-> IO (AlarmClock t)
newAlarmClock onWakeUp = newAlarmClock' $ const . onWakeUp
newAlarmClock'
:: TimeScale t
=> (AlarmClock t -> t -> IO ())
-> IO (AlarmClock t)
newAlarmClock' onWakeUp = mfix $ \ac -> do
acAsync <- async $ runAlarmClock ac (onWakeUp ac)
AlarmClock (wait acAsync) <$> newTVarIO AlarmNotSet <*> newTVarIO False
destroyAlarmClock :: AlarmClock t -> IO ()
destroyAlarmClock AlarmClock{..} = atomically (writeTVar acNewSetting AlarmDestroyed) >> acWaitForExit
withAlarmClock :: TimeScale t
=> (AlarmClock t -> t -> IO ())
-> (AlarmClock t -> IO a) -> IO a
withAlarmClock onWakeUp inner = bracket (newAlarmClock' onWakeUp) destroyAlarmClock inner
setAlarm :: TimeScale t => AlarmClock t -> t -> IO ()
setAlarm ac t = atomically $ setAlarmSTM ac t
setAlarmSTM :: TimeScale t => AlarmClock t -> t -> STM ()
setAlarmSTM AlarmClock{..} t = modifyTVar' acNewSetting $ \case
AlarmDestroyed -> AlarmDestroyed
AlarmNotSet -> AlarmSet t
AlarmSet t' -> AlarmSet $! earlierOf t t'
setAlarmNow :: TimeScale t => AlarmClock t -> IO ()
setAlarmNow alarm = getAbsoluteTime >>= setAlarm alarm
isAlarmSet :: AlarmClock t -> IO Bool
isAlarmSet = atomically . isAlarmSetSTM
isAlarmSetSTM :: AlarmClock t -> STM Bool
isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting
>>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }
data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed
labelMyThread :: String -> IO ()
labelMyThread threadLabel = myThreadId >>= flip labelThread threadLabel
runAlarmClock :: TimeScale t => AlarmClock t -> (t -> 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
timeoutLength <- microsecondsDiff wakeUpTime <$> getAbsoluteTime
safeTimeout timeoutLength readNextSetting >>= \case
Nothing -> actAndContinue
Just newSetting -> go newSetting
safeTimeout dt action
| dt > 0 = timeout dt action
| otherwise = return Nothing
actAndContinue = do
atomically $ writeTVar acIsSet False
wakeUpAction =<< getAbsoluteTime
loop