{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
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,
toNanoSecs)
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) $ toNanoSecs $ 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 >>= handleNewSetting
readNextSetting = atomically $ readTVar acNewSetting >>= \case
AlarmNotSet -> retry
AlarmDestroyed -> return Nothing
AlarmSet t -> do
writeTVar acNewSetting AlarmNotSet
writeTVar acIsSet True
return $ Just t
handleNewSetting Nothing = return ()
handleNewSetting (Just wakeUpTime) = wakeShortlyAfter wakeUpTime
wakeShortlyAfter wakeUpTime = do
now <- getAbsoluteTime
let microsecondsTimeout = microsecondsDiff wakeUpTime now
if 0 < microsecondsTimeout
then maybe (wakeShortlyAfter wakeUpTime) handleNewSetting
=<< timeout microsecondsTimeout readNextSetting
else do
atomically $ writeTVar acIsSet False
wakeUpAction now
loop