diff --git a/alarmclock.cabal b/alarmclock.cabal --- a/alarmclock.cabal +++ b/alarmclock.cabal @@ -1,5 +1,5 @@ name: alarmclock -version: 0.3.0.1 +version: 0.4.0.1 synopsis: Wake up and perform an action at a certain time. description: Wake up and perform an action at a certain time. homepage: https://bitbucket.org/davecturner/alarmclock @@ -15,18 +15,11 @@ library exposed-modules: Control.Concurrent.AlarmClock build-depends: - base >=4.8 && <4.9 + base >=4.8 && <4.10 , stm , time + , clock , unbounded-delays hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - -executable test - main-is: Main.hs - hs-source-dirs: test - default-language: Haskell2010 - build-depends: base - , alarmclock - , time diff --git a/src/Control/Concurrent/AlarmClock.hs b/src/Control/Concurrent/AlarmClock.hs --- a/src/Control/Concurrent/AlarmClock.hs +++ b/src/Control/Concurrent/AlarmClock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-| Device for running an action at (i.e. shortly after) a certain time, which @@ -31,42 +31,72 @@ , setAlarmNow , isAlarmSet , isAlarmSetSTM + , TimeScale(..) + , MonotonicTime(..) ) where -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) +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, + readMVar) +import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', + newTVar, readTVar, retry, + writeTVar) +import Control.Concurrent.Timeout (timeout) +import Control.Exception (bracket, finally) +import Control.Monad (void) +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 + +{-| Representation of system monotonic clock. #-} +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 + {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -} -data AlarmClock = AlarmClock +data AlarmClock t = AlarmClock { acWaitForExit :: IO () - , acNewSetting :: TVar AlarmSetting + , acNewSetting :: TVar (AlarmSetting t) , acIsSet :: TVar Bool } {-| Create a new 'AlarmClock' that runs the given action. Initially, there is no wakeup time set: you must call 'setAlarm' for anything else to happen. -} newAlarmClock - :: (AlarmClock -> IO ()) + :: TimeScale t + => (AlarmClock t -> IO ()) -- ^ Action to run when the alarm goes off. The action is provided the alarm clock -- so it can set a new alarm if desired. Note that `setAlarm` must be called once -- the alarm has gone off to cause it to go off again. - -> IO AlarmClock + -> IO (AlarmClock t) newAlarmClock onWakeUp = newAlarmClock' $ const . onWakeUp {-| Create a new 'AlarmClock' that runs the given action. Initially, there is no wakeup time set: you must call 'setAlarm' for anything else to happen. -} newAlarmClock' - :: (AlarmClock -> UTCTime -> IO ()) + :: TimeScale t + => (AlarmClock t -> t -> IO ()) -- ^ Action to run when the alarm goes off. The action is provided the alarm clock -- so it can set a new alarm if desired, and the current time. -- Note that `setAlarm` must be called once the alarm has gone off to cause -- it to go off again. - -> IO AlarmClock + -> IO (AlarmClock t) newAlarmClock' onWakeUp = do joinVar <- newEmptyMVar ac <- atomically $ AlarmClock (readMVar joinVar) <$> newTVar AlarmNotSet <*> newTVar False @@ -75,48 +105,50 @@ {-| Destroy the 'AlarmClock' so no further alarms will occur. If the alarm is currently going off then this will block until the action is finished. -} -destroyAlarmClock :: AlarmClock -> IO () +destroyAlarmClock :: AlarmClock t -> IO () destroyAlarmClock AlarmClock{..} = atomically (writeTVar acNewSetting AlarmDestroyed) >> acWaitForExit {-| The action @withAlarmClock onWakeUp inner@ runs @inner@ with a new 'AlarmClock' which is destroyed when @inner@ exits. -} -withAlarmClock :: (AlarmClock -> UTCTime -> IO ()) -> (AlarmClock -> IO a) -> IO a +withAlarmClock :: TimeScale t + => (AlarmClock t -> t -> IO ()) + -> (AlarmClock t -> IO a) -> IO a withAlarmClock onWakeUp inner = bracket (newAlarmClock' onWakeUp) destroyAlarmClock inner {-| Make the 'AlarmClock' go off at (or shortly after) the given time. This can be called more than once; in which case, the alarm will go off at the earliest given time. -} -setAlarm :: AlarmClock -> UTCTime -> IO () +setAlarm :: TimeScale t => AlarmClock t -> t -> IO () setAlarm ac t = atomically $ setAlarmSTM ac t {-| Make the 'AlarmClock' go off at (or shortly after) the given time. This can be called more than once; in which case, the alarm will go off at the earliest given time. -} -setAlarmSTM :: AlarmClock -> UTCTime -> STM () +setAlarmSTM :: TimeScale t => AlarmClock t -> t -> STM () setAlarmSTM AlarmClock{..} t = modifyTVar' acNewSetting $ \case AlarmDestroyed -> AlarmDestroyed AlarmNotSet -> AlarmSet t - AlarmSet t' -> AlarmSet $! min t t' + AlarmSet t' -> AlarmSet $! earlierOf t t' {-| Make the 'AlarmClock' go off right now. -} -setAlarmNow :: AlarmClock -> IO () -setAlarmNow alarm = getCurrentTime >>= setAlarm alarm +setAlarmNow :: TimeScale t => AlarmClock t -> IO () +setAlarmNow alarm = getAbsoluteTime >>= setAlarm alarm {-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -} -isAlarmSet :: AlarmClock -> IO Bool +isAlarmSet :: AlarmClock t -> IO Bool isAlarmSet = atomically . isAlarmSetSTM {-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -} -isAlarmSetSTM :: AlarmClock -> STM Bool +isAlarmSetSTM :: AlarmClock t -> STM Bool isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True } -data AlarmSetting = AlarmNotSet | AlarmSet UTCTime | AlarmDestroyed +data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed labelMyThread :: String -> IO () labelMyThread threadLabel = myThreadId >>= flip labelThread threadLabel -runAlarmClock :: AlarmClock -> (UTCTime -> IO ()) -> IO () +runAlarmClock :: TimeScale t => AlarmClock t -> (t -> IO ()) -> IO () runAlarmClock AlarmClock{..} wakeUpAction = labelMyThread "alarmclock" >> loop where loop = readNextSetting >>= go @@ -133,9 +165,8 @@ go (Just wakeUpTime) = wakeNoLaterThan wakeUpTime wakeNoLaterThan wakeUpTime = do - currentTime <- getCurrentTime - let dt = ceiling $ (1000000 *) $ diffUTCTime wakeUpTime currentTime - safeTimeout dt readNextSetting >>= \case + timeoutLength <- microsecondsDiff wakeUpTime <$> getAbsoluteTime + safeTimeout timeoutLength readNextSetting >>= \case Nothing -> actAndContinue Just newSetting -> go newSetting @@ -146,5 +177,5 @@ actAndContinue = do atomically $ writeTVar acIsSet False - wakeUpAction =<< getCurrentTime + wakeUpAction =<< getAbsoluteTime loop diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Main (main) where - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.AlarmClock -import Control.Exception -import Data.IORef -import Data.Time -import Text.Printf - -printWithTime :: String -> IO () -printWithTime s = do - t <- getCurrentTime - putStrLn $ printf "%-32s: %s" (show t) s - -alarmAction :: IORef Bool -> AlarmClock -> IO () -alarmAction v ac = do - printWithTime "alarm went off" - threadDelay 3000000 - readIORef v >>= \case - False -> return () - True -> do - t <- addUTCTime 5 <$> getCurrentTime - setAlarmLog ac t - threadDelay 3000000 - printWithTime "alarm action finished" - -setAlarmLog :: AlarmClock -> UTCTime -> IO () -setAlarmLog ac t = do - printWithTime $ printf "alarm set for %s" $ show t - setAlarm ac t - -setAlarmNowLog :: AlarmClock -> IO () -setAlarmNowLog ac = do - printWithTime "alarm set for now" - setAlarmNow ac - -main :: IO () -main = do - v <- newIORef True - bracket (newAlarmClock $ alarmAction v) destroyAlarmClock $ \ac -> do - t <- getCurrentTime - mask $ \_ -> do - setAlarmLog ac $ addUTCTime 2 t - setAlarmLog ac $ addUTCTime (pred 2) t - setAlarmLog ac $ addUTCTime (succ 2) t - threadDelay 500000 - setAlarmLog ac $ addUTCTime 4 t - threadDelay 1900000 - setAlarmNowLog ac - threadDelay 8000000 - printWithTime "cancelling alarm repeat" - writeIORef v False - threadDelay 7000000 - setAlarmLog ac $ addUTCTime 1 t - threadDelay 500000 - setAlarmLog ac $ addUTCTime 20 t - threadDelay 4000000 - printWithTime "done"