control-event 0.3.1 → 1.0.0.0

raw patch · 5 files changed

+99/−73 lines, 5 filesdep +timedep −old-timedep ~basedep ~containersdep ~stmPVP ok

version bump matches the API change (PVP)

Dependencies added: time

Dependencies removed: old-time

Dependency ranges changed: base, containers, stm

API changes (from Hackage documentation)

Files

• Control/Event.hs +25/−40
• Control/Event/Relative.hs +40/−0
• Control/Event/Timeout.hs +10/−11
• Test/Event.hs +12/−16
• control-event.cabal +12/−6

@@ -1,18 +1,7 @@ -- |This module can execute events at specified time.  It uses a two thread  -- system that allows the STM adding and deleting of new threads without--- requiring later IO actions. ------ This differs from control-timeout in that control-event is:---   * More complex---   * Requires initilization---   * Allows pure STM adding and removing of events (no post STM IO action)---   * Allows user control over event systems (can have more than one)---   * Allows events to run in event handler thread ---     (advisable if thread spark is too expensive / computation is cheap)---   * No possible duplication of EventId (theoretical! no real advantage)------  A shim has been made providing control-timeout API with ---  Control.Event running under the hood (called Control.Event.Timeout).+-- requiring later IO actions.  For a simpler system that uses relative times+-- see Control.Event.Relative module Control.Event ( 	 EventId 	,EventSystem@@ -25,15 +14,15 @@ 	,evtSystemSize 	) where -import Prelude hiding (lookup)+import Prelude hiding (lookup, catch) import Control.Concurrent (forkIO, myThreadId, ThreadId, threadDelay) import Control.Concurrent.STM-import Control.Exception (throwDynTo, catchDyn, block, unblock)+import Control.Exception import Control.Monad (forever, when) import Data.Dynamic import Data.List (partition, deleteBy) import Data.Map (Map, empty, findMin, deleteFindMin, insertLookupWithKey, adjust, size, singleton, toList, insert, updateLookupWithKey, delete, lookup, fold)-import System.Time (TimeDiff(..), ClockTime(..), diffClockTimes, getClockTime)+import Data.Time  type EventNumber = Int type EventSet = (EventNumber, Map EventNumber (IO ()))@@ -41,23 +30,23 @@ singletonSet a = (1, singleton 0 a)  -- |IDs useful for canceling previously scheduled events.-data EventId = EvtId ClockTime EventNumber deriving (Eq, Ord, Show)+data EventId = EvtId UTCTime EventNumber deriving (Eq, Ord, Show)  -- |A value indicating there is no such event. -- Canceling this event returns True and has no other effect. noEvent :: EventId noEvent = EvtId never (-1) -never :: ClockTime-never = TOD (-1) (-1)+never :: UTCTime +never = UTCTime (toEnum (-1)) (-1)  -- |The event system must be initilized using initEventSystem. -- More than one event system can be instantiated at once -- (eg. for non-interference). data EventSystem = EvtSys {-    esEvents :: TVar (Map ClockTime EventSet),      -- Pending Events+    esEvents :: TVar (Map UTCTime EventSet),      -- Pending Events     esThread :: TVar (Maybe ThreadId),              -- Id of thread for TimerReset exceptions-    esAlarm  :: TVar ClockTime,                     -- Time of soonest event+    esAlarm  :: TVar UTCTime,                     -- Time of soonest event     esNewAlarm :: TVar Bool,                        -- An event w/ earlier expiration was added     esExpired  :: TVar [[EventSet]]     }@@ -88,7 +77,7 @@ expireEvents es = do 	block (do 		tid <- myThreadId-		forever $ catchDyn (unblock (setTID (Just tid) es >> expireEvents' es))+		forever $ catch (unblock (setTID (Just tid) es >> expireEvents' es)) 				(\TimerReset -> return ()) )   where   setTID i es = atomically (writeTVar (esThread es) i)@@ -107,17 +96,17 @@              case findMinM evts of                Nothing    -> retry                Just (c,_) -> return c ) -    now <- getClockTime-    return $ timeDiffToMicroSec $ diffClockTimes alm now+    now <- getCurrentTime+    return $ timeDiffToMicroSec $ diffUTCTime alm now -  findMinM :: Map ClockTime EventSet -> Maybe (ClockTime,EventSet)+  findMinM :: Map UTCTime EventSet -> Maybe (UTCTime,EventSet)   findMinM m | size m == 0 = Nothing              | otherwise   = Just $ findMin m  -- |Determines which events are expired, running all their actions runExpire :: EventSystem -> IO () runExpire evtSys = do-    now  <- getClockTime+    now  <- getCurrentTime     atomically (do  evts <- readTVar (esEvents evtSys)                     let (exp, newMap) = getEarlierKeys now evts                         newAlarm = getAlarm newMap@@ -126,7 +115,7 @@                     exps <- readTVar (esExpired evtSys) 		    writeTVar (esExpired evtSys) (exp:exps) )   where-  getEarlierKeys :: ClockTime -> Map ClockTime EventSet -> ([EventSet], Map ClockTime EventSet)+  getEarlierKeys :: UTCTime -> Map UTCTime EventSet -> ([EventSet], Map UTCTime EventSet)   getEarlierKeys clk m =       case deleteFindMinM m of           Just ((k,es), m') ->@@ -159,11 +148,11 @@     mapM_ forkIO actions  -- |Add an *action* to be performed at *time* by *system*.  Returns a unique ID.-addEvent :: EventSystem -> ClockTime -> IO () -> IO EventId+addEvent :: EventSystem -> UTCTime -> IO () -> IO EventId addEvent sys clk act = atomically (addEventSTM sys clk act)  -- |Atomic version of addEvent-addEventSTM :: EventSystem -> ClockTime -> IO () -> STM EventId+addEventSTM :: EventSystem -> UTCTime -> IO () -> STM EventId addEventSTM sys clk act = do     evts <- readTVar (esEvents sys)     let (old, newMap) = insertLookupWithKey (\_ _ o -> insertEvent o) clk (singletonSet act) evts@@ -190,9 +179,9 @@ cancelEventSTM :: EventSystem -> EventId -> STM Bool cancelEventSTM sys eid@(EvtId clk num) = do     evts <- readTVar (esEvents sys)-    let newMap :: Map ClockTime EventSet+    let newMap :: Map UTCTime EventSet         prev :: Maybe EventSet-        (prev,newMap) = updateLookupWithKey (\_ (num, old) -> Just (num,delete num old)) clk evts+        (prev,newMap) = updateLookupWithKey (\_ (cnt, old) -> Just (cnt,delete num old)) clk evts         ret = case prev of 		Nothing -> False -- error "Canceling an event that never existed." 		Just (_,p)  -> case lookup clk newMap of@@ -220,16 +209,12 @@ 	                Just i  -> return i 			Nothing -> retry                return i )-    throwDynTo tid TimerReset+    throwTo tid TimerReset  -- |Returns the time difference in microseconds (potentially returning maxBound <= the real difference)-timeDiffToMicroSec :: TimeDiff -> Int-timeDiffToMicroSec (TimeDiff _ _ _ _ _ sec picosec) =-    if realTime > fromIntegral (maxBound :: Int)-        then maxBound-	else fromIntegral realTime-  where-  realTime :: Integer-  realTime = (fromIntegral sec) * (10^6) + fromIntegral (picosec `div` (10^6))+timeDiffToMicroSec :: NominalDiffTime -> Int+timeDiffToMicroSec = floor . (* 10^6)  data TimerReset = TimerReset deriving (Eq, Ord, Show, Typeable)++instance Exception TimerReset

@@ -0,0 +1,40 @@+-- |This module uses Haskell concurrency libraries to build an extremely simple+-- event system that should perform better than the Control.Event module+-- but does not provide features such as STM action scheduling.+module Control.Event.Relative+	( EventId+	, addEvent+	, delEvent+	) where++import Prelude hiding (catch)+import Control.Concurrent+import Control.Exception+import Control.Concurrent.MVar++type EventId = (ThreadId, MVar ())++-- |'addEvent delay action' will delay+-- for 'delay' miliseconds then execute 'action'. An EventId+-- is returned, allowing the event to be canceled.+addEvent :: Int -> IO () -> IO EventId+addEvent delay event = do+	m <- newEmptyMVar+	t <- forkIO (eventThread m)+	return (t,m)+  where+    eventThread m = do+	threadDelay delay+	forkIO event+	putMVar m ()++-- |'delEvent eid' deletes the event and returns+-- 'True' if the event was _probably_ deleted*.  If 'False' is returned+-- then the time definately elapsed and the action was forked off.+--+-- * There is a small possibility the delEvent occured after the forkIO+-- but before the signalling MVar was filled, thus causing this uncertainty.+delEvent :: EventId -> IO Bool+delEvent (t,m) =+	killThread t >>+	isEmptyMVar m

@@ -1,5 +1,7 @@ -- |This module is a shim, providing the control-timeout api using--- control-event to run the show+-- control-event to run the show.  See the control-timeout package+-- for documentation.  If you do not need compatability with+-- the control-timeout api then do not use this module!  module Control.Event.Timeout (       addTimeout@@ -10,31 +12,28 @@ import System.IO.Unsafe import Control.Concurrent.STM import Control.Event-import System.Time+import Data.Time  {-# NOINLINE evtSys #-} evtSys = unsafePerformIO initEventSystem  newtype TimeoutTag = TTag EventId -addTimeout :: Float -> (IO ()) -> IO TimeoutTag+addTimeout :: Float -> IO () -> IO TimeoutTag addTimeout delay act = do     clk <- getExpireTime delay     i <- addEvent evtSys clk act     return $ TTag i -addTimeoutAtomic :: Float -> IO () -> IO (STM TimeoutTag)-addTimeoutAtomic delay act = do+addTimeoutAtomic :: Float -> IO (IO () -> IO (STM TimeoutTag))+addTimeoutAtomic delay = return $ \act -> do     clk <- getExpireTime delay     return $ addEventSTM evtSys clk act >>= return . TTag  cancelTimeout :: TimeoutTag -> STM Bool cancelTimeout (TTag eid) = cancelEventSTM evtSys eid -getExpireTime :: Float -> IO ClockTime+getExpireTime :: Float -> IO UTCTime getExpireTime delay = do-    (TOD sec ps) <- getClockTime-    let dSec = truncate delay-        dPS  = truncate $ (delay - fromIntegral dSec) * 10^12-        clk  = TOD (sec + dSec) (ps + dPS)-    return clk+    now <- getCurrentTime+    return (addUTCTime (fromRational $ toRational delay) now)

@@ -2,23 +2,20 @@  import Control.Concurrent import Control.Concurrent.STM--import Data.Time.Clock.POSIX-import System.Time import Control.Event-import GHC.Conc (unsafeIOToSTM)- import Text.Printf (printf)+import Data.Time+import Data.Time.Clock.POSIX -singleTimeout :: Float -> IO ()+singleTimeout :: NominalDiffTime -> IO () singleTimeout secs = do   sys <- initEventSystem   a <- atomically $ newTVar 0   startTime <- getPOSIXTime-  now@(TOD sec picosec) <- getClockTime+  now <- getCurrentTime   let newSec = truncate secs       newPS  = truncate $ 10^12 * (secs - (fromIntegral newSec))-  addEvent sys (TOD (sec + newSec) (picosec + newPS)) (getPOSIXTime >>= atomically . writeTVar a)+  addEvent sys (addUTCTime secs now) (getPOSIXTime >>= atomically . writeTVar a)   endTime <- atomically (do     t <- readTVar a     if t == 0@@ -26,13 +23,13 @@        else return t)   printf "%dms sleep took: %s\n" ((truncate $ secs * 1000) :: Int) (show (endTime - startTime)) -multiTimeout :: Int -> Float -> IO ()+multiTimeout :: Int -> NominalDiffTime -> IO () multiTimeout n secs = do   sys <- initEventSystem   a <- atomically $ newTVar n-  now@(TOD sec picosec) <- getClockTime+  now <- getCurrentTime   startTime <- getPOSIXTime-  mapM_ (const $ addEvent sys (TOD (sec + truncate secs) picosec) (decAndPrint a)) [1..n]+  mapM_ (const $ addEvent sys (addUTCTime secs now) (decAndPrint a)) [1..n]   atomically (do     n' <- readTVar a     if n' == 0@@ -47,13 +44,13 @@           n <- readTVar a 	  writeTVar a (n - 1) ) -setAndCancelTimeout :: Int -> Float -> IO ()+setAndCancelTimeout :: Int -> NominalDiffTime -> IO () setAndCancelTimeout n secs = do   sys <- initEventSystem   a <- atomically $ newTVar (0 :: Int)-  now@(TOD sec picosec) <- getClockTime+  now <- getCurrentTime   startTime <- getPOSIXTime-  tags <- mapM (const $ addEvent sys (TOD (sec + truncate secs) picosec) (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n]+  tags <- mapM (const $ addEvent sys (addUTCTime secs now) (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n]   mapM (cancelEvent sys) tags   endTime <- getPOSIXTime   expired <- atomically $ readTVar a@@ -62,7 +59,6 @@  main = do   sequence [singleTimeout 0, singleTimeout 0.1, singleTimeout 0.5, singleTimeout 1.0]-  sequence [multiTimeout 10 0.1, multiTimeout 100 0.1, multiTimeout 1000 0.1, multiTimeout 10000 0.1, multiTimeout 100000 0.1]-  sequence [multiTimeout 1000 0.1, multiTimeout 10000 0.1, multiTimeout 100000 0.1]+  sequence [multiTimeout 10 0.1, multiTimeout 100 0.1, multiTimeout 1000 0.1, multiTimeout 10000 0.1]   sequence [setAndCancelTimeout 10 0.1, setAndCancelTimeout 100 0.1, setAndCancelTimeout 1000 0.1, setAndCancelTimeout 10000 0.1, setAndCancelTimeout 100000 0.1]   return ()

@@ -1,5 +1,5 @@ name:                control-event-version:             0.3.1+version:             1.0.0.0 synopsis:            Event scheduling system. description:         Allows scheduling and canceling of IO actions to be                      executed at a specified future time.@@ -9,9 +9,15 @@ author:              Thomas DuBuisson maintainer:          Thomas.DuBuisson@gmail.com build-type:          Simple-build-Depends:       base, old-time, containers >= 0.1, stm-extensions:          DeriveDataTypeable-exposed-modules:     Control.Event, Control.Event.Timeout-stability:           alpha-tested-with:         GHC == 6.8.2+Cabal-Version:       >= 1.2.3+stability:           beta+tested-with:         GHC == 6.10.3 extra-source-files:  Test/Event.hs Test/Timeout.hs++Library+  build-Depends:       base >= 4.0 && < 5,+                       time >= 1.1 && < 1.2,+                       containers >= 0.1 && < 0.3,+                       stm >= 2.1 && < 2.2+  extensions:          DeriveDataTypeable+  exposed-modules:     Control.Event, Control.Event.Timeout, Control.Event.Relative