diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/alarmclock.cabal b/alarmclock.cabal --- a/alarmclock.cabal +++ b/alarmclock.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 8d07c55bfbba37064e7a34b1ddfaeb436a9c8a9c2335f1bb78be9cb1827d6d37 +-- hash: 3d079241564ac100016ed2bad6050d1543f11df47698f2a6035f587e0db961b0 name: alarmclock -version: 0.5.0.2 +version: 0.6.0.1 synopsis: Wake up and perform an action at a certain time. description: Please see the README on Bitbucket at category: Concurrency @@ -21,6 +21,7 @@ library hs-source-dirs: src + ghc-options: -Wall build-depends: async , base >=4.8 && <4.12 @@ -40,7 +41,7 @@ main-is: Spec.hs hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: alarmclock , async 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 @@ -35,24 +35,28 @@ , MonotonicTime(..) ) where -import Control.Concurrent.Async (async, wait) +import Control.Concurrent.Async (async, wait, waitSTM, + withAsync) import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', - newTVarIO, readTVar, - retry, writeTVar) -import Control.Concurrent.Timeout (timeout) + newTVarIO, orElse, + readTVar, retry, + writeTVar) +import Control.Concurrent.Thread.Delay (delay) import Control.Exception (bracket) import Control.Monad.Fix (mfix) import GHC.Conc (labelThread, myThreadId) +import Control.Monad (join) import Control.Concurrent.AlarmClock.TimeScale +data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed + {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -} data AlarmClock t = AlarmClock { acWaitForExit :: IO () , acNewSetting :: TVar (AlarmSetting t) - , acIsSet :: TVar Bool } {-| Create a new 'AlarmClock' that runs the given action. Initially, there is @@ -78,7 +82,7 @@ -> IO (AlarmClock t) newAlarmClock' onWakeUp = mfix $ \ac -> do acAsync <- async $ runAlarmClock ac (onWakeUp ac) - AlarmClock (wait acAsync) <$> newTVarIO AlarmNotSet <*> newTVarIO False + AlarmClock (wait acAsync) <$> newTVarIO AlarmNotSet {-| 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. -} @@ -103,9 +107,9 @@ earliest given time. -} setAlarmSTM :: TimeScale t => AlarmClock t -> t -> STM () setAlarmSTM AlarmClock{..} t = modifyTVar' acNewSetting $ \case - AlarmDestroyed -> AlarmDestroyed AlarmNotSet -> AlarmSet t AlarmSet t' -> AlarmSet $! earlierOf t t' + AlarmDestroyed -> AlarmDestroyed {-| Make the 'AlarmClock' go off right now. -} setAlarmNow :: TimeScale t => AlarmClock t -> IO () @@ -118,9 +122,7 @@ {-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -} isAlarmSetSTM :: AlarmClock t -> STM Bool isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting - >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True } - -data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed + >>= \case { AlarmSet _ -> return True; _ -> return False } labelMyThread :: String -> IO () labelMyThread threadLabel = myThreadId >>= flip labelThread threadLabel @@ -128,26 +130,29 @@ 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 + loop :: IO () + loop = join $ atomically whenNotSet - handleNewSetting Nothing = return () - handleNewSetting (Just wakeUpTime) = wakeShortlyAfter wakeUpTime + whenNotSet :: STM (IO ()) + whenNotSet = readTVar acNewSetting >>= \case + AlarmNotSet -> retry + AlarmDestroyed -> return $ return () + AlarmSet wakeUpTime -> return $ whenSet wakeUpTime - wakeShortlyAfter wakeUpTime = do + whenSet wakeUpTime = do now <- getAbsoluteTime let microsecondsTimeout = microsecondsDiff wakeUpTime now if 0 < microsecondsTimeout - then maybe (wakeShortlyAfter wakeUpTime) handleNewSetting - =<< timeout microsecondsTimeout readNextSetting + then join $ withAsync (delay microsecondsTimeout) $ \a -> atomically $ + waitSTM a >> return (whenSet wakeUpTime) + `orElse` + (readTVar acNewSetting >>= \case + AlarmSet wakeUpTime' | earlierOf wakeUpTime' wakeUpTime /= wakeUpTime -> return $ whenSet wakeUpTime' + AlarmDestroyed -> return $ return () + _ -> retry + ) + else do - atomically $ writeTVar acIsSet False + atomically $ writeTVar acNewSetting AlarmNotSet wakeUpAction now loop diff --git a/src/Control/Concurrent/AlarmClock/TimeScale.hs b/src/Control/Concurrent/AlarmClock/TimeScale.hs --- a/src/Control/Concurrent/AlarmClock/TimeScale.hs +++ b/src/Control/Concurrent/AlarmClock/TimeScale.hs @@ -30,7 +30,7 @@ -} -class TimeScale t where +class Eq t => TimeScale t where getAbsoluteTime :: IO t microsecondsDiff :: t -> t -> Integer earlierOf :: t -> t -> t diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -50,6 +50,10 @@ return (modifyIORef logVar . (:), reverse <$> readIORef logVar) describe "AlarmClock" $ do + let waitUntilUnset ac = do + atomically $ guard . not =<< isAlarmSetSTM ac + threadDelay 50000 -- alarm becomes unset before action has completed + it "wakes up immediately on setAlarmNow" $ do (writeLog, readLog) <- makeLog withAlarmClock (\_ _ -> writeLog "alarm went off") $ \ac -> do @@ -126,7 +130,7 @@ setAlarmSTM ac $ addUTCTime 0.1 now guard =<< isAlarmSetSTM ac writeLog "alarm is set" - atomically $ guard . not =<< isAlarmSetSTM ac + waitUntilUnset ac writeLog "alarm now not set again" readLog `shouldReturn` [ "alarm is set" @@ -140,11 +144,11 @@ startTime <- getCurrentTime setAlarm ac $ addUTCTime 0.1 startTime writeLog "alarm is set" - atomically $ guard . not =<< isAlarmSetSTM ac + waitUntilUnset ac writeLog "alarm is not set" setAlarm ac $ addUTCTime 0.2 startTime writeLog "alarm is set" - atomically $ guard . not =<< isAlarmSetSTM ac + waitUntilUnset ac writeLog "alarm is not set" readLog `shouldReturn` [ "alarm is set" @@ -161,7 +165,7 @@ startTime <- getCurrentTime setAlarm ac $ addUTCTime (-0.1) startTime writeLog "alarm is set" - atomically $ guard . not =<< isAlarmSetSTM ac + waitUntilUnset ac writeLog "done" endTime <- getCurrentTime diffUTCTime endTime startTime `shouldSatisfy` (\t -> 0.0 <= t && t < 0.1)