alarmclock 0.1.0.1 → 0.1.0.2

raw patch · 2 files changed

+43/−33 lines, 2 filesdep +stmdep +stm-chansPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, stm-chans

API changes (from Hackage documentation)

Files

• alarmclock.cabal +3/−1
• src/Control/Concurrent/AlarmClock.hs +40/−32

@@ -1,5 +1,5 @@ name:                alarmclock-version:             0.1.0.1+version:             0.1.0.2 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@@ -16,6 +16,8 @@   exposed-modules:     Control.Concurrent.AlarmClock   build-depends:       base >=4.7 && <4.8+    , stm+    , stm-chans     , time   hs-source-dirs:      src   default-language:    Haskell2010

@@ -14,8 +14,8 @@ To perform time-based cache expiry, create an 'AlarmClock' whose action flushes any stale entries from the cache and returns the next time that an entry will expire. If the cache contains no entries that will expire, return 'Nothing'-from the reaper action. When expiring entries are added to the cache, call-'setAlarm' to ensure that they will be reaped.+from the alarm action. When expiring entries are added to the cache, call+'setAlarm' to ensure that they will expire in a timely fashion.  -} @@ -27,14 +27,17 @@   , setAlarmNow   ) where +import Control.Applicative import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMQueue import Control.Exception import Control.Monad-import System.Timeout import Data.Time+import System.Timeout  {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}-data AlarmClock = AlarmClock (MVar UTCTime) ThreadId+newtype AlarmClock = AlarmClock (TBMQueue UTCTime)  {-| 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. -}@@ -46,48 +49,53 @@     -- been called with a time that is still in the future.   -> IO AlarmClock newAlarmClock onWakeUp = do-  mv <- newEmptyMVar-  tid <- mask $ \restore -> forkIO $ runAlarmClock mv $ void $ forkIO $-    restore onWakeUp >>= \case Nothing -> return ()-                               Just wakeUpTime -> setAlarmVar mv wakeUpTime -  return $ AlarmClock mv tid+  ac <- atomically $ AlarmClock <$> newTBMQueue 1+  void $ mask $ \restore -> forkIO $ runAlarmClock ac $ restore onWakeUp+  return ac  {-| Destroy the 'AlarmClock' so no further alarms will occur. If a wakeup is in progress then it will run to completion. -} destroyAlarmClock :: AlarmClock -> IO ()-destroyAlarmClock (AlarmClock _ tid) = killThread tid--setAlarmVar :: MVar UTCTime -> UTCTime -> IO ()-setAlarmVar mv wakeUpTime = tryTakeMVar mv >>= \case-  Nothing          -> putMVar mv      wakeUpTime-  Just wakeUpTime' -> putMVar mv (min wakeUpTime wakeUpTime')+destroyAlarmClock (AlarmClock q) = atomically $ closeTBMQueue q -{-| 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 first given time. -}+{-| 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 (AlarmClock mv _) = setAlarmVar mv+setAlarm (AlarmClock q) = atomically . writeTBMQueue q  {-| Make the 'AlarmClock' go off right now. -} setAlarmNow :: AlarmClock -> IO () setAlarmNow alarm = getCurrentTime >>= setAlarm alarm -runAlarmClock :: MVar UTCTime -> IO () -> IO ()-runAlarmClock wakeUpTimeVar wakeUpAction = alarmNotSet+data AlarmSetting = AlarmNotSet | AlarmSet UTCTime | AlarmDestroyed++readNextAlarmSetting :: AlarmClock -> IO AlarmSetting+readNextAlarmSetting (AlarmClock q)+  = maybe AlarmDestroyed AlarmSet <$> atomically (readTBMQueue q)++runAlarmClock :: AlarmClock -> IO (Maybe UTCTime) -> IO ()+runAlarmClock ac wakeUpAction = go AlarmNotSet   where-  alarmNotSet = takeMVar wakeUpTimeVar >>= alarmSet+  go AlarmDestroyed = return ()+  go AlarmNotSet    = readNextAlarmSetting ac >>= go+  go (AlarmSet wakeUpTime) = do+    dt <- diffUTCTime wakeUpTime <$> getCurrentTime+    if dt < 0+      then actAndContinue+      else timeout (fromIntegral $ min maxDelay $ ceiling $ 1000000 * dt)+                   (readNextAlarmSetting ac)+            >>= \case+              Nothing -> do+                t' <- getCurrentTime+                if t' < wakeUpTime+                  then go (AlarmSet wakeUpTime)+                  else actAndContinue+              Just newSetting -> go newSetting -  alarmSet wakeUpTime = do-    t <- getCurrentTime-    let dt = diffUTCTime wakeUpTime t-    if dt < 0 then wakeUpAction >> alarmNotSet-              else timeout (fromIntegral $ min maxDelay $ ceiling $ 1000000 * dt)-                           (takeMVar wakeUpTimeVar) >>= \case-          Nothing -> do-            t' <- getCurrentTime-            if t' < wakeUpTime then alarmSet wakeUpTime else wakeUpAction >> alarmNotSet+  act = wakeUpAction >>= maybe (return ()) (setAlarm ac) -          Just wakeUpTime' -> alarmSet (min wakeUpTime wakeUpTime')+  actAndContinue = forkIO act >> go AlarmNotSet  maxDelay :: Integer maxDelay = fromIntegral (maxBound :: Int)