hunk ./Control/Event.hs 3
--- 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
hunk ./Control/Event.hs 17
-import Prelude hiding (lookup)
+import Prelude hiding (lookup, catch)
hunk ./Control/Event.hs 20
-import Control.Exception (throwDynTo, catchDyn, block, unblock)
+import Control.Exception
hunk ./Control/Event.hs 25
-import System.Time (TimeDiff(..), ClockTime(..), diffClockTimes, getClockTime)
+import Data.Time
hunk ./Control/Event.hs 33
-data EventId = EvtId ClockTime EventNumber deriving (Eq, Ord, Show)
+data EventId = EvtId UTCTime EventNumber deriving (Eq, Ord, Show)
hunk ./Control/Event.hs 40
-never :: ClockTime
-never = TOD (-1) (-1)
+never :: UTCTime 
+never = UTCTime (toEnum (-1)) (-1)
hunk ./Control/Event.hs 47
-    esEvents :: TVar (Map ClockTime EventSet),      -- Pending Events
+    esEvents :: TVar (Map UTCTime EventSet),      -- Pending Events
hunk ./Control/Event.hs 49
-    esAlarm  :: TVar ClockTime,                     -- Time of soonest event
+    esAlarm  :: TVar UTCTime,                     -- Time of soonest event
hunk ./Control/Event.hs 80
-		forever $ catchDyn (unblock (setTID (Just tid) es >> expireEvents' es))
+		forever $ catch (unblock (setTID (Just tid) es >> expireEvents' es))
hunk ./Control/Event.hs 99
-    now <- getClockTime
-    return $ timeDiffToMicroSec $ diffClockTimes alm now
+    now <- getCurrentTime
+    return $ timeDiffToMicroSec $ diffUTCTime alm now
hunk ./Control/Event.hs 102
-  findMinM :: Map ClockTime EventSet -> Maybe (ClockTime,EventSet)
+  findMinM :: Map UTCTime EventSet -> Maybe (UTCTime,EventSet)
hunk ./Control/Event.hs 109
-    now  <- getClockTime
+    now  <- getCurrentTime
hunk ./Control/Event.hs 118
-  getEarlierKeys :: ClockTime -> Map ClockTime EventSet -> ([EventSet], Map ClockTime EventSet)
+  getEarlierKeys :: UTCTime -> Map UTCTime EventSet -> ([EventSet], Map UTCTime EventSet)
hunk ./Control/Event.hs 151
-addEvent :: EventSystem -> ClockTime -> IO () -> IO EventId
+addEvent :: EventSystem -> UTCTime -> IO () -> IO EventId
hunk ./Control/Event.hs 155
-addEventSTM :: EventSystem -> ClockTime -> IO () -> STM EventId
+addEventSTM :: EventSystem -> UTCTime -> IO () -> STM EventId
hunk ./Control/Event.hs 182
-    let newMap :: Map ClockTime EventSet
+    let newMap :: Map UTCTime EventSet
hunk ./Control/Event.hs 184
-        (prev,newMap) = updateLookupWithKey (\_ (num, old) -> Just (num,delete num old)) clk evts
+        (prev,newMap) = updateLookupWithKey (\_ (cnt, old) -> Just (cnt,delete num old)) clk evts
hunk ./Control/Event.hs 212
-    throwDynTo tid TimerReset
+    throwTo tid TimerReset
hunk ./Control/Event.hs 215
-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)
hunk ./Control/Event.hs 219
+
+instance Exception TimerReset
hunk ./Control/Event/Timeout.hs 2
--- 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!
hunk ./Control/Event/Timeout.hs 15
-import System.Time
+import Data.Time
hunk ./Control/Event/Timeout.hs 22
-addTimeout :: Float -> (IO ()) -> IO TimeoutTag
+addTimeout :: Float -> IO () -> IO TimeoutTag
hunk ./Control/Event/Timeout.hs 28
-addTimeoutAtomic :: Float -> IO () -> IO (STM TimeoutTag)
-addTimeoutAtomic delay act = do
+addTimeoutAtomic :: Float -> IO (IO () -> IO (STM TimeoutTag))
+addTimeoutAtomic delay = return $ \act -> do
hunk ./Control/Event/Timeout.hs 36
-getExpireTime :: Float -> IO ClockTime
+getExpireTime :: Float -> IO UTCTime
hunk ./Control/Event/Timeout.hs 38
-    (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)
hunk ./Test/Event.hs 5
-
-import Data.Time.Clock.POSIX
-import System.Time
hunk ./Test/Event.hs 6
-import GHC.Conc (unsafeIOToSTM)
-
hunk ./Test/Event.hs 7
+import Data.Time
+import Data.Time.Clock.POSIX
hunk ./Test/Event.hs 10
-singleTimeout :: Float -> IO ()
+singleTimeout :: NominalDiffTime -> IO ()
hunk ./Test/Event.hs 15
-  now@(TOD sec picosec) <- getClockTime
+  now <- getCurrentTime
hunk ./Test/Event.hs 18
-  addEvent sys (TOD (sec + newSec) (picosec + newPS)) (getPOSIXTime >>= atomically . writeTVar a)
+  addEvent sys (addUTCTime secs now) (getPOSIXTime >>= atomically . writeTVar a)
hunk ./Test/Event.hs 26
-multiTimeout :: Int -> Float -> IO ()
+multiTimeout :: Int -> NominalDiffTime -> IO ()
hunk ./Test/Event.hs 30
-  now@(TOD sec picosec) <- getClockTime
+  now <- getCurrentTime
hunk ./Test/Event.hs 32
-  mapM_ (const $ addEvent sys (TOD (sec + truncate secs) picosec) (decAndPrint a)) [1..n]
+  mapM_ (const $ addEvent sys (addUTCTime secs now) (decAndPrint a)) [1..n]
hunk ./Test/Event.hs 47
-setAndCancelTimeout :: Int -> Float -> IO ()
+setAndCancelTimeout :: Int -> NominalDiffTime -> IO ()
hunk ./Test/Event.hs 51
-  now@(TOD sec picosec) <- getClockTime
+  now <- getCurrentTime
hunk ./Test/Event.hs 53
-  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]
hunk ./Test/Event.hs 62
-  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]
hunk ./Test/Test.hs 6
-import System.Time
+import Data.Time
+import Control.Monad (when)
hunk ./Test/Test.hs 9
-
-secDelay :: Integer
+secDelay :: NominalDiffTime
hunk ./Test/Test.hs 15
-tol :: Int
+tol :: NominalDiffTime
hunk ./Test/Test.hs 19
---    runTest "testOneEvent" testOneEvent
---    runTest "testManyEvents 50" (testManyEvents 50)
---    runTest "testDeletingEvents 50" (testDeletingEvents 50)
---    runTest "testOnTime [8,1]" (testOnTime [8,1])
+    runTest "testOneEvent" testOneEvent
+    runTest "testManyEvents 5000" (testManyEvents 5000)
+    runTest "testDeletingEvents 5000" (testDeletingEvents 5000)
+    runTest "testOnTime [8,1]" (testOnTime [8,1])
hunk ./Test/Test.hs 24
---    runTest "testOnTime [2,4,8]" (testOnTime [2,4,8])
---    runTest "testOnTime [1,1,1,1...]" (testOnTime (take 20 (repeat 1)))
+    runTest "testOnTime [2,4,8]" (testOnTime [2,4,8])
+    runTest "testOnTime [1,1,1,1...]" (testOnTime (take 20 (repeat 1)))
hunk ./Test/Test.hs 37
-    (TOD sec picosec) <- getClockTime
-    let clk = TOD (sec + secDelay) picosec
+    now <- getCurrentTime
+    let clk = addUTCTime secDelay now
hunk ./Test/Test.hs 47
-    (TOD sec picosec) <- getClockTime
-    let clks = map (\_ -> TOD (sec + secDelay) picosec) [1..nrEvts]
+    now <- getCurrentTime
+    let clks = map (\_ -> addUTCTime secDelay now) [1..nrEvts]
hunk ./Test/Test.hs 57
-    (TOD sec picosec) <- getClockTime
-    let clks = map (\_ -> TOD (sec + secDelay) picosec) [1..nrEvents]
+    now <- getCurrentTime
+    let clks = [alarm | _ <- [1..nrEvents]]
+        alarm = addUTCTime secDelay now
hunk ./Test/Test.hs 63
-    atomically (readTVar tv >>= return . (==nrEvents))
+    r <- atomically (readTVar tv)
+    let res = r == nrEvents
+    when (not res) (do
+	putStrLn ("There were " ++ (show (nrEvents - r)) ++ " lapsed events\n")
+	putStrLn ("Start: " ++ (show now))
+	putStrLn ("Alarm: " ++ (show alarm)))
+    return res
hunk ./Test/Test.hs 71
-testOnTime :: [Integer] -> IO Bool
+testOnTime :: [NominalDiffTime] -> IO Bool
hunk ./Test/Test.hs 75
---    atomically (setEventPreprocessing sys neverForkEvents)
-    (TOD sec picosec) <- getClockTime
-    let clks = map (\d -> TOD (sec + d) picosec) delays
+    now <- getCurrentTime
+    let clks = map (\d -> addUTCTime d now) delays
hunk ./Test/Test.hs 78
-    threadDelay $ fromIntegral $ (maximum delays + fromIntegral tol)*10^6
+    threadDelay $ ceiling $ (maximum delays + tol)*10^6
hunk ./Test/Test.hs 81
-theTimeIsNow :: ClockTime -> TVar Int -> IO ()
+theTimeIsNow :: UTCTime -> TVar Int -> IO ()
hunk ./Test/Test.hs 83
-	now <- getClockTime
-	let (TimeDiff _ _ _ _ _ sec _) = diffClockTimes now clk
-	if sec > tol
-		then do putStrLn ("Time error of " ++ (show sec) ++ " seconds")
+	now <- getCurrentTime
+	let diff = diffUTCTime now clk
+	if diff > tol
+		then do putStrLn ("Time error of " ++ (show diff) ++ " seconds")
hunk ./control-event.cabal 2
-version:             0.3.1
+version:             1.1.0.0
hunk ./control-event.cabal 12
-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
hunk ./control-event.cabal 16
+
+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
addfile ./Control/Event/Relative.hs
hunk ./Control/Event/Relative.hs 1
+-- |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.Monad (when)
+import Control.Concurrent.MVar
+
+type EventId = (ThreadId, MVar Bool)
+
+-- |'addEvent delay action' will delay
+-- for 'delay' microseconds 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 $ runThread m
+	return ()
+    runThread m = do
+        b <- swapMVar m True
+        when (not b) event
+
+
+-- |'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.
+delEvent :: EventId -> IO Bool
+delEvent (t,m) = do
+    killThread t
+    b <- swapMVar m True
+    return (not b)
hunk ./Control/Event/Relative.hs 37
--- 'True' if the event was _probably_ deleted*.  If 'False' is returned
--- then the time definately elapsed and the action was forked off.
+-- 'True' if the event was deleted.  If 'False' is returned
+-- then the time elapsed and the action was forked off.
hunk ./control-event.cabal 2
-version:             1.1.0.0
+version:             1.1.0.1
hunk ./Control/Event.hs 184
-        (prev,newMap) = updateLookupWithKey (\_ (cnt, old) -> Just (cnt,delete num old)) clk evts
+        (prev,newMap) = insertLookupWithKey (\_ _ (cnt, old) -> (cnt,delete num old)) clk undefined evts
hunk ./control-event.cabal 2
-version:             1.1.0.1
+version:             1.1.0.2
hunk ./control-event.cabal 2
-version:             1.1.0.2
+version:             1.1.0.3
hunk ./control-event.cabal 20
-                       containers >= 0.1 && < 0.3,
+                       containers >= 0.1 && < 0.4,
hunk ./Control/Event/Relative.hs 23
-	m <- newEmptyMVar
+	m <- newMVar False
hunk ./Control/Event/Relative.hs 41
-    killThread t
-    b <- swapMVar m True
+    b <- takeMVar m
+    when (not b) (killThread t)
+    putMVar m True
hunk ./control-event.cabal 2
-version:             1.1.0.3
+version:             1.1.0.4
hunk ./control-event.cabal 19
-                       time >= 1.1 && < 1.2,
+                       time >= 1.1 && < 1.3,
hunk ./control-event.cabal 21
-                       stm >= 2.1 && < 2.2
+                       stm >= 2.1 && < 2.3
hunk ./control-event.cabal 2
-version:             1.1.0.4
+version:             1.2.0.0
hunk ./control-event.cabal 20
-                       containers >= 0.1 && < 0.4,
+                       containers >= 0.1 && < 0.5,
hunk ./control-event.cabal 2
-version:             1.2.0.0
+version:             1.2.1.0