alarmclock 0.3.0.1 → 0.4.0.1
raw patch · 3 files changed
+63/−100 lines, 3 filesdep +clockdep −alarmclockdep ~base
Dependencies added: clock
Dependencies removed: alarmclock
Dependency ranges changed: base
Files
- alarmclock.cabal +3/−10
- src/Control/Concurrent/AlarmClock.hs +60/−29
- test/Main.hs +0/−61
alarmclock.cabal view
@@ -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
src/Control/Concurrent/AlarmClock.hs view
@@ -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
− test/Main.hs
@@ -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"