alarmclock 0.1.0.2 → 0.2.0.1

raw patch · 3 files changed

+42/−35 lines, 3 filesdep −stm-chansPVP ok

version bump matches the API change (PVP)

Dependencies removed: stm-chans

API changes (from Hackage documentation)

Files

• alarmclock.cabal +1/−2
• src/Control/Concurrent/AlarmClock.hs +34/−26
• test/Main.hs +7/−7

@@ -1,5 +1,5 @@ name:                alarmclock-version:             0.1.0.2+version:             0.2.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@@ -17,7 +17,6 @@   build-depends:       base >=4.7 && <4.8     , stm-    , stm-chans     , time   hs-source-dirs:      src   default-language:    Haskell2010

@@ -30,39 +30,44 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM-import Control.Concurrent.STM.TBMQueue import Control.Exception import Control.Monad import Data.Time import System.Timeout  {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}-newtype AlarmClock = AlarmClock (TBMQueue UTCTime)+data AlarmClock = AlarmClock (IO ()) (TVar AlarmSetting)  {-| 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-  :: IO (Maybe UTCTime)-    -- ^ Action to run when the alarm goes off. The return value, if 'Just', is-    -- used as the next wakeup time. If 'Nothing', the alarm will not wake up again-    -- until 'setAlarm' or 'setAlarmNow' is called, even if 'setAlarm' has previously-    -- been called with a time that is still in the future.+  :: (AlarmClock -> 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 newAlarmClock onWakeUp = do-  ac <- atomically $ AlarmClock <$> newTBMQueue 1-  void $ mask $ \restore -> forkIO $ runAlarmClock ac $ restore onWakeUp+  joinVar <- atomically $ newTVar False+  ac <- atomically $ AlarmClock (waitOn joinVar) <$> newTVar AlarmNotSet+  void $ forkIO $ runAlarmClock ac (onWakeUp ac) `finally` atomically (writeTVar joinVar True)   return ac -{-| Destroy the 'AlarmClock' so no further alarms will occur. If a wakeup is in-progress then it will run to completion. -}+waitOn :: TVar Bool -> IO ()+waitOn v = atomically $ readTVar v >>= \case True -> return (); False -> retry++{-| 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 q) = atomically $ closeTBMQueue q+destroyAlarmClock (AlarmClock j q) = atomically (writeTVar q AlarmDestroyed) >> j  {-| 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 q) = atomically . writeTBMQueue q+setAlarm (AlarmClock _ q) t = atomically $ modifyTVar' q $ \case+  AlarmDestroyed -> AlarmDestroyed+  AlarmNotSet -> AlarmSet t+  AlarmSet t' -> AlarmSet $! min t t'  {-| Make the 'AlarmClock' go off right now. -} setAlarmNow :: AlarmClock -> IO ()@@ -70,18 +75,23 @@  data AlarmSetting = AlarmNotSet | AlarmSet UTCTime | AlarmDestroyed -readNextAlarmSetting :: AlarmClock -> IO AlarmSetting-readNextAlarmSetting (AlarmClock q)-  = maybe AlarmDestroyed AlarmSet <$> atomically (readTBMQueue q)+readNextAlarmSetting :: AlarmClock -> IO (Maybe UTCTime)+readNextAlarmSetting (AlarmClock _ q) = atomically $ readTVar q >>= \case+  AlarmNotSet    -> retry+  AlarmDestroyed -> return Nothing+  AlarmSet t     -> writeTVar q AlarmNotSet >> return (Just t) -runAlarmClock :: AlarmClock -> IO (Maybe UTCTime) -> IO ()-runAlarmClock ac wakeUpAction = go AlarmNotSet+runAlarmClock :: AlarmClock -> IO () -> IO ()+runAlarmClock ac wakeUpAction = loop   where-  go AlarmDestroyed = return ()-  go AlarmNotSet    = readNextAlarmSetting ac >>= go-  go (AlarmSet wakeUpTime) = do+  loop = readNextAlarmSetting ac >>= go++  go Nothing           = return ()+  go (Just wakeUpTime) = wakeNoLaterThan wakeUpTime++  wakeNoLaterThan wakeUpTime = do     dt <- diffUTCTime wakeUpTime <$> getCurrentTime-    if dt < 0+    if dt <= 0       then actAndContinue       else timeout (fromIntegral $ min maxDelay $ ceiling $ 1000000 * dt)                    (readNextAlarmSetting ac)@@ -89,13 +99,11 @@               Nothing -> do                 t' <- getCurrentTime                 if t' < wakeUpTime-                  then go (AlarmSet wakeUpTime)+                  then wakeNoLaterThan wakeUpTime                   else actAndContinue               Just newSetting -> go newSetting -  act = wakeUpAction >>= maybe (return ()) (setAlarm ac)--  actAndContinue = forkIO act >> go AlarmNotSet+  actAndContinue = wakeUpAction >> loop  maxDelay :: Integer maxDelay = fromIntegral (maxBound :: Int)

@@ -15,17 +15,17 @@   t <- getCurrentTime   putStrLn $ printf "%-32s: %s" (show t) s -alarmAction :: IORef Bool -> IO (Maybe UTCTime)-alarmAction v = do+alarmAction :: IORef Bool -> AlarmClock -> IO ()+alarmAction v ac = do   printWithTime "alarm went off"+  threadDelay 3000000   readIORef v >>= \case-    False -> do-      printWithTime "not resetting alarm"-      return Nothing+    False -> return ()     True -> do       t <- addUTCTime 5 <$> getCurrentTime-      printWithTime $ printf "alarm reset for %s" $ show t-      return $ Just t+      setAlarmLog ac t+  threadDelay 3000000+  printWithTime "alarm action finished"  setAlarmLog :: AlarmClock -> UTCTime -> IO () setAlarmLog ac t = do