stm-delay 0.1.1 → 0.1.1.1
raw patch · 5 files changed
+509/−485 lines, 5 filessetup-changed
Files
- Control/Concurrent/STM/Delay.hs +302/−278
- LICENSE +30/−30
- Setup.hs +2/−2
- stm-delay.cabal +80/−80
- test/Main.hs +95/−95
Control/Concurrent/STM/Delay.hs view
@@ -1,278 +1,302 @@-{-# LANGUAGE CPP #-} --- | --- Module: Control.Concurrent.STM.Delay --- Copyright: (c) Joseph Adams 2012 --- License: BSD3 --- Maintainer: joeyadams3.14159@gmail.com --- Portability: Requires GHC 7+ --- --- One-shot timer whose duration can be updated. Think of it as an enhanced --- version of 'registerDelay'. --- --- This uses "GHC.Event" when available (GHC 7.2+, @-threaded@, non-Windows OS). --- Otherwise, it falls back to forked threads and 'threadDelay'. -module Control.Concurrent.STM.Delay ( - -- * Managing delays - Delay, - newDelay, - updateDelay, - cancelDelay, - - -- * Waiting for expiration - waitDelay, - tryWaitDelay, - tryWaitDelayIO, - - -- * Example - -- $example -) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (mask_) -import Control.Monad - -#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS -import qualified GHC.Event as Ev -#endif - --- | A 'Delay' is an updatable timer that rings only once. -data Delay = Delay - { delayVar :: !(TVar Bool) - , delayUpdate :: !(Int -> IO ()) - , delayCancel :: !(IO ()) - } - -instance Eq Delay where - (==) a b = delayVar a == delayVar b - --- | Create a new 'Delay' that will ring in the given number of microseconds. -newDelay :: Int -> IO Delay -newDelay t - | t > 0 = getDelayImpl t - - -- Special case zero timeout, so user can create an - -- already-rung 'Delay' efficiently. - | otherwise = do - var <- newTVarIO True - return Delay - { delayVar = var - , delayUpdate = \_t -> return () - , delayCancel = return () - } - --- | Set an existing 'Delay' to ring in the given number of microseconds --- (from the time 'updateDelay' is called), rather than when it was going to --- ring. If the 'Delay' has already rung, do nothing. -updateDelay :: Delay -> Int -> IO () -updateDelay = delayUpdate - --- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later. --- If the 'Delay' has already rung, do nothing. -cancelDelay :: Delay -> IO () -cancelDelay = delayCancel - --- | Block until the 'Delay' rings. If the 'Delay' has already rung, --- return immediately. -waitDelay :: Delay -> STM () -waitDelay delay = do - expired <- tryWaitDelay delay - if expired then return () - else retry - --- | Non-blocking version of 'waitDelay'. --- Return 'True' if the 'Delay' has rung. -tryWaitDelay :: Delay -> STM Bool -tryWaitDelay = readTVar . delayVar - --- | Faster version of @'atomically' . 'tryWaitDelay'@. See 'readTVarIO'. --- --- Since 0.1.1 -tryWaitDelayIO :: Delay -> IO Bool -tryWaitDelayIO = readTVarIO . delayVar - ------------------------------------------------------------------------- --- Drivers - -getDelayImpl :: Int -> IO Delay -#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS -getDelayImpl t0 = do - m <- Ev.getSystemEventManager - case m of - Nothing -> implThread t0 - Just mgr -> implEvent mgr t0 -#else -getDelayImpl = implThread -#endif - -#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS --- | Use the timeout API in "GHC.Event" -implEvent :: Ev.EventManager -> Int -> IO Delay -implEvent mgr t0 = do - var <- newTVarIO False - k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True - return Delay - { delayVar = var - , delayUpdate = Ev.updateTimeout mgr k - , delayCancel = Ev.unregisterTimeout mgr k - } -#endif - --- | Use threads and threadDelay: --- --- [init] --- Fork a thread to wait the given length of time, then set the TVar. --- --- [delayUpdate] --- Stop the existing thread and (unless the delay has been canceled) --- fork a new thread. --- --- [delayCancel] --- Stop the existing thread, if any. -implThread :: Int -> IO Delay -implThread t0 = do - var <- newTVarIO False - let new t = forkTimeoutThread t $ atomically $ writeTVar var True - mv <- new t0 >>= newMVar . Just - return Delay - { delayVar = var - , delayUpdate = replaceThread mv . fmap Just . new - , delayCancel = replaceThread mv $ return Nothing - } - -replaceThread :: MVar (Maybe TimeoutThread) - -> IO (Maybe TimeoutThread) - -> IO () -replaceThread mv new = - join $ mask_ $ do - m <- takeMVar mv - case m of - Nothing -> do - -- Don't create a new timer thread after the 'Delay' has - -- been canceled. Otherwise, the behavior is inconsistent - -- with GHC.Event. - putMVar mv Nothing - return (return ()) - Just tt -> do - m' <- stopTimeoutThread tt - case m' of - Nothing -> do - -- Timer already rang (or will ring very soon). - -- Don't start a new timer thread, as it would - -- waste resources and have no externally - -- observable effect. - putMVar mv Nothing - return $ return () - Just kill -> do - new >>= putMVar mv - return kill - ------------------------------------------------------------------------- --- TimeoutThread - -data TimeoutThread = TimeoutThread !ThreadId !(MVar ()) - --- | Fork a thread to perform an action after the given number of --- microseconds. --- --- 'forkTimeoutThread' is non-interruptible. -forkTimeoutThread :: Int -> IO () -> IO TimeoutThread -forkTimeoutThread t io = do - mv <- newMVar () - tid <- compat_forkIOUnmasked $ do - threadDelay t - m <- tryTakeMVar mv - -- If m is Just, this thread will not be interrupted, - -- so no need for a 'mask' between the tryTakeMVar and the action. - case m of - Nothing -> return () - Just _ -> io - return (TimeoutThread tid mv) - --- | Prevent the 'TimeoutThread' from performing its action. If it's too late, --- return 'Nothing'. Otherwise, return an action (namely, 'killThread') for --- cleaning up the underlying thread. --- --- 'stopTimeoutThread' has a nice property: it is /non-interruptible/. --- This means that, in an exception 'mask', it will not poll for exceptions. --- See "Control.Exception" for more info. --- --- However, the action returned by 'stopTimeoutThread' /does/ poll for --- exceptions. That's why 'stopTimeoutThread' returns this action rather than --- simply doing it. This lets the caller do it outside of a critical section. -stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ())) -stopTimeoutThread (TimeoutThread tid mv) = - maybe Nothing (\_ -> Just (killThread tid)) `fmap` tryTakeMVar mv - ------------------------------------------------------------------------- --- Compatibility - -compat_forkIOUnmasked :: IO () -> IO ThreadId -#if MIN_VERSION_base(4,4,0) -compat_forkIOUnmasked io = forkIOWithUnmask (\_ -> io) -#else -compat_forkIOUnmasked = forkIOUnmasked -#endif - ------------------------------------------------------------------------- - -{- $example -Suppose we are managing a network connection, and want to time it out if no -messages are received in over five minutes. We'll create a 'Delay', and an -action to \"bump\" it: - -@ - let timeoutInterval = 5 * 60 * 1000000 :: 'Int' - delay <- 'newDelay' timeoutInterval - let bump = 'updateDelay' delay timeoutInterval -@ - -This way, the 'Delay' will ring if it is not bumped for longer than -five minutes. - -Now we fork the receiver thread: - -@ - dead <- 'newEmptyTMVarIO' - _ <- 'forkIO' $ - ('forever' $ do - msg <- recvMessage - bump - handleMessage msg - ) \`finally\` 'atomically' ('putTMVar' dead ()) -@ - -Finally, we wait for the delay to ring, or for the receiver thread to fail due -to an exception: - -@ - 'atomically' $ 'waitDelay' delay \`orElse\` 'readTMVar' dead -@ - -Warning: - - * If /handleMessage/ blocks, the 'Delay' may ring due to @handleMessage@ - taking too long, rather than just @recvMessage@ taking too long. - - * The loop will continue to run until you do something to stop it. - -It might be simpler to use "System.Timeout" instead: - -@ - m <- 'System.Timeout.timeout' timeoutInterval recvMessage - case m of - Nothing -> 'fail' \"timed out\" - Just msg -> handleMessage msg -@ - -However, using a 'Delay' has the following advantages: - - * If @recvMessage@ makes a blocking FFI call (e.g. network I/O on Windows), - 'System.Timeout.timeout' won't work, since it uses an asynchronous - exception, and FFI calls can't be interrupted with async exceptions. - The 'Delay' approach lets you handle the timeout in another thread, - while the FFI call is still blocked. - - * 'updateDelay' is more efficient than 'System.Timeout.timeout' when - "GHC.Event" is available. --} +{-# LANGUAGE CPP #-}+-- |+-- Module: Control.Concurrent.STM.Delay+-- Copyright: (c) Joseph Adams 2012+-- License: BSD3+-- Maintainer: joeyadams3.14159@gmail.com+-- Portability: Requires GHC 7++--+-- One-shot timer whose duration can be updated. Think of it as an enhanced+-- version of 'registerDelay'.+--+-- This uses "GHC.Event" when available (GHC 7.2+, @-threaded@, non-Windows OS).+-- Otherwise, it falls back to forked threads and 'threadDelay'.+module Control.Concurrent.STM.Delay (+ -- * Managing delays+ Delay,+ newDelay,+ updateDelay,+ cancelDelay,++ -- * Waiting for expiration+ waitDelay,+ tryWaitDelay,+ tryWaitDelayIO,++ -- * Example+ -- $example+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (mask_)+import Control.Monad++#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+import qualified GHC.Event as Ev+#endif++#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS+import qualified GHC.Conc as Conc+#endif++-- | A 'Delay' is an updatable timer that rings only once.+data Delay = Delay+ { delayVar :: !(TVar Bool)+ , delayUpdate :: !(Int -> IO ())+ , delayCancel :: !(IO ())+ }++instance Eq Delay where+ (==) a b = delayVar a == delayVar b++-- | Create a new 'Delay' that will ring in the given number of microseconds.+newDelay :: Int -> IO Delay+newDelay t+ | t > 0 = getDelayImpl t++ -- Special case zero timeout, so user can create an+ -- already-rung 'Delay' efficiently.+ | otherwise = do+ var <- newTVarIO True+ return Delay+ { delayVar = var+ , delayUpdate = \_t -> return ()+ , delayCancel = return ()+ }++-- | Set an existing 'Delay' to ring in the given number of microseconds+-- (from the time 'updateDelay' is called), rather than when it was going to+-- ring. If the 'Delay' has already rung, do nothing.+updateDelay :: Delay -> Int -> IO ()+updateDelay = delayUpdate++-- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later.+-- If the 'Delay' has already rung, do nothing.+cancelDelay :: Delay -> IO ()+cancelDelay = delayCancel++-- | Block until the 'Delay' rings. If the 'Delay' has already rung,+-- return immediately.+waitDelay :: Delay -> STM ()+waitDelay delay = do+ expired <- tryWaitDelay delay+ if expired then return ()+ else retry++-- | Non-blocking version of 'waitDelay'.+-- Return 'True' if the 'Delay' has rung.+tryWaitDelay :: Delay -> STM Bool+tryWaitDelay = readTVar . delayVar++-- | Faster version of @'atomically' . 'tryWaitDelay'@. See 'readTVarIO'.+--+-- Since 0.1.1+tryWaitDelayIO :: Delay -> IO Bool+tryWaitDelayIO = readTVarIO . delayVar++------------------------------------------------------------------------+-- Drivers++getDelayImpl :: Int -> IO Delay+#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS+getDelayImpl t0 = do+ Conc.ensureIOManagerIsRunning+ m <- Ev.getSystemEventManager+ case m of+ Nothing -> implThread t0+ Just _ -> do+ mgr <- Ev.getSystemTimerManager+ implEvent mgr t0+#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+getDelayImpl t0 = do+ m <- Ev.getSystemEventManager+ case m of+ Nothing -> implThread t0+ Just mgr -> implEvent mgr t0+#else+getDelayImpl = implThread+#endif++#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS+-- | Use the timeout API in "GHC.Event" via TimerManager+--implEvent :: Ev.TimerManager -> Int -> IO Delay+implEvent mgr t0 = do+ var <- newTVarIO False+ k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True+ return Delay+ { delayVar = var+ , delayUpdate = Ev.updateTimeout mgr k+ , delayCancel = Ev.unregisterTimeout mgr k+ }+#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+-- | Use the timeout API in "GHC.Event"+implEvent :: Ev.EventManager -> Int -> IO Delay+implEvent mgr t0 = do+ var <- newTVarIO False+ k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True+ return Delay+ { delayVar = var+ , delayUpdate = Ev.updateTimeout mgr k+ , delayCancel = Ev.unregisterTimeout mgr k+ }+#endif++-- | Use threads and threadDelay:+--+-- [init]+-- Fork a thread to wait the given length of time, then set the TVar.+--+-- [delayUpdate]+-- Stop the existing thread and (unless the delay has been canceled)+-- fork a new thread.+--+-- [delayCancel]+-- Stop the existing thread, if any.+implThread :: Int -> IO Delay+implThread t0 = do+ var <- newTVarIO False+ let new t = forkTimeoutThread t $ atomically $ writeTVar var True+ mv <- new t0 >>= newMVar . Just+ return Delay+ { delayVar = var+ , delayUpdate = replaceThread mv . fmap Just . new+ , delayCancel = replaceThread mv $ return Nothing+ }++replaceThread :: MVar (Maybe TimeoutThread)+ -> IO (Maybe TimeoutThread)+ -> IO ()+replaceThread mv new =+ join $ mask_ $ do+ m <- takeMVar mv+ case m of+ Nothing -> do+ -- Don't create a new timer thread after the 'Delay' has+ -- been canceled. Otherwise, the behavior is inconsistent+ -- with GHC.Event.+ putMVar mv Nothing+ return (return ())+ Just tt -> do+ m' <- stopTimeoutThread tt+ case m' of+ Nothing -> do+ -- Timer already rang (or will ring very soon).+ -- Don't start a new timer thread, as it would+ -- waste resources and have no externally+ -- observable effect.+ putMVar mv Nothing+ return $ return ()+ Just kill -> do+ new >>= putMVar mv+ return kill++------------------------------------------------------------------------+-- TimeoutThread++data TimeoutThread = TimeoutThread !ThreadId !(MVar ())++-- | Fork a thread to perform an action after the given number of+-- microseconds.+--+-- 'forkTimeoutThread' is non-interruptible.+forkTimeoutThread :: Int -> IO () -> IO TimeoutThread+forkTimeoutThread t io = do+ mv <- newMVar ()+ tid <- compat_forkIOUnmasked $ do+ threadDelay t+ m <- tryTakeMVar mv+ -- If m is Just, this thread will not be interrupted,+ -- so no need for a 'mask' between the tryTakeMVar and the action.+ case m of+ Nothing -> return ()+ Just _ -> io+ return (TimeoutThread tid mv)++-- | Prevent the 'TimeoutThread' from performing its action. If it's too late,+-- return 'Nothing'. Otherwise, return an action (namely, 'killThread') for+-- cleaning up the underlying thread.+--+-- 'stopTimeoutThread' has a nice property: it is /non-interruptible/.+-- This means that, in an exception 'mask', it will not poll for exceptions.+-- See "Control.Exception" for more info.+--+-- However, the action returned by 'stopTimeoutThread' /does/ poll for+-- exceptions. That's why 'stopTimeoutThread' returns this action rather than+-- simply doing it. This lets the caller do it outside of a critical section.+stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))+stopTimeoutThread (TimeoutThread tid mv) =+ maybe Nothing (\_ -> Just (killThread tid)) `fmap` tryTakeMVar mv++------------------------------------------------------------------------+-- Compatibility++compat_forkIOUnmasked :: IO () -> IO ThreadId+#if MIN_VERSION_base(4,4,0)+compat_forkIOUnmasked io = forkIOWithUnmask (\_ -> io)+#else+compat_forkIOUnmasked = forkIOUnmasked+#endif++------------------------------------------------------------------------++{- $example+Suppose we are managing a network connection, and want to time it out if no+messages are received in over five minutes. We'll create a 'Delay', and an+action to \"bump\" it:++@+ let timeoutInterval = 5 * 60 * 1000000 :: 'Int'+ delay <- 'newDelay' timeoutInterval+ let bump = 'updateDelay' delay timeoutInterval+@++This way, the 'Delay' will ring if it is not bumped for longer than+five minutes.++Now we fork the receiver thread:++@+ dead <- 'newEmptyTMVarIO'+ _ <- 'forkIO' $+ ('forever' $ do+ msg <- recvMessage+ bump+ handleMessage msg+ ) \`finally\` 'atomically' ('putTMVar' dead ())+@++Finally, we wait for the delay to ring, or for the receiver thread to fail due+to an exception:++@+ 'atomically' $ 'waitDelay' delay \`orElse\` 'readTMVar' dead+@++Warning:++ * If /handleMessage/ blocks, the 'Delay' may ring due to @handleMessage@+ taking too long, rather than just @recvMessage@ taking too long.++ * The loop will continue to run until you do something to stop it.++It might be simpler to use "System.Timeout" instead:++@+ m <- 'System.Timeout.timeout' timeoutInterval recvMessage+ case m of+ Nothing -> 'fail' \"timed out\"+ Just msg -> handleMessage msg+@++However, using a 'Delay' has the following advantages:++ * If @recvMessage@ makes a blocking FFI call (e.g. network I/O on Windows),+ 'System.Timeout.timeout' won't work, since it uses an asynchronous+ exception, and FFI calls can't be interrupted with async exceptions.+ The 'Delay' approach lets you handle the timeout in another thread,+ while the FFI call is still blocked.++ * 'updateDelay' is more efficient than 'System.Timeout.timeout' when+ "GHC.Event" is available.+-}
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2012, Joseph Adams - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Joseph Adams nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2012, Joseph Adams++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Joseph Adams nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
stm-delay.cabal view
@@ -1,80 +1,80 @@-name: stm-delay -version: 0.1.1 -synopsis: Updatable one-shot timer polled with STM -description: - This library lets you create a one-shot timer, poll it using STM, - and update it to ring at a different time than initially specified. - . - It uses GHC event manager timeouts when available - (GHC 7.2+, @-threaded@, non-Windows OS), yielding performance similar - to @threadDelay@ and @registerDelay@. Otherwise, it falls back to - forked threads and @threadDelay@. - . - [0.1.1] - Add tryWaitDelayIO, improve performance for certain cases of @newDelay@ - and @updateDelay@, and improve example. -homepage: https://github.com/joeyadams/haskell-stm-delay -license: BSD3 -license-file: LICENSE -author: Joey Adams -maintainer: joeyadams3.14159@gmail.com -copyright: Copyright (c) Joseph Adams 2012 -category: System -build-type: Simple -cabal-version: >= 1.8 - -source-repository head - type: git - location: git://github.com/joeyadams/haskell-stm-delay.git - -library - exposed-modules: - Control.Concurrent.STM.Delay - - ghc-options: -Wall -fwarn-tabs - - build-depends: base >= 4.3 && < 5 - , stm - - -- Need base >= 4.3 for: - -- - -- * Control.Exception.mask - -- - -- * forkIOUnmasked - -- - -- * A threadDelay that doesn't give (-1) magic treatment. - -- See http://hackage.haskell.org/trac/ghc/ticket/2892 - -- - -- * GHC.Event (called System.Event in base 4.3) - -test-suite test - type: exitcode-stdio-1.0 - - hs-source-dirs: test - main-is: Main.hs - - ghc-options: -Wall - -fno-warn-missing-signatures - -fno-warn-name-shadowing - -fno-warn-unused-do-bind - -fno-warn-unused-matches - - build-depends: base >= 4.3 && < 5 - , stm - , stm-delay - -test-suite test-threaded - type: exitcode-stdio-1.0 - - hs-source-dirs: test - main-is: Main.hs - - ghc-options: -Wall -threaded - -fno-warn-missing-signatures - -fno-warn-name-shadowing - -fno-warn-unused-do-bind - -fno-warn-unused-matches - - build-depends: base >= 4.3 && < 5 - , stm - , stm-delay +name: stm-delay+version: 0.1.1.1+synopsis: Updatable one-shot timer polled with STM+description:+ This library lets you create a one-shot timer, poll it using STM,+ and update it to ring at a different time than initially specified.+ .+ It uses GHC event manager timeouts when available+ (GHC 7.2+, @-threaded@, non-Windows OS), yielding performance similar+ to @threadDelay@ and @registerDelay@. Otherwise, it falls back to+ forked threads and @threadDelay@.+ .+ [0.1.1]+ Add tryWaitDelayIO, improve performance for certain cases of @newDelay@+ and @updateDelay@, and improve example.+homepage: https://github.com/joeyadams/haskell-stm-delay+license: BSD3+license-file: LICENSE+author: Joey Adams+maintainer: joeyadams3.14159@gmail.com+copyright: Copyright (c) Joseph Adams 2012+category: System+build-type: Simple+cabal-version: >= 1.8++source-repository head+ type: git+ location: git://github.com/joeyadams/haskell-stm-delay.git++library+ exposed-modules:+ Control.Concurrent.STM.Delay++ ghc-options: -Wall -fwarn-tabs++ build-depends: base >= 4.3 && < 5+ , stm++ -- Need base >= 4.3 for:+ --+ -- * Control.Exception.mask+ --+ -- * forkIOUnmasked+ --+ -- * A threadDelay that doesn't give (-1) magic treatment.+ -- See http://hackage.haskell.org/trac/ghc/ticket/2892+ --+ -- * GHC.Event (called System.Event in base 4.3)++test-suite test+ type: exitcode-stdio-1.0++ hs-source-dirs: test+ main-is: Main.hs++ ghc-options: -Wall+ -fno-warn-missing-signatures+ -fno-warn-name-shadowing+ -fno-warn-unused-do-bind+ -fno-warn-unused-matches++ build-depends: base >= 4.3 && < 5+ , stm+ , stm-delay++test-suite test-threaded+ type: exitcode-stdio-1.0++ hs-source-dirs: test+ main-is: Main.hs++ ghc-options: -Wall -threaded+ -fno-warn-missing-signatures+ -fno-warn-name-shadowing+ -fno-warn-unused-do-bind+ -fno-warn-unused-matches++ build-depends: base >= 4.3 && < 5+ , stm+ , stm-delay
test/Main.hs view
@@ -1,95 +1,95 @@-{-# LANGUAGE CPP #-} - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.STM.Delay - -main = trivial - -trivial = do - let new t = do - delay <- newDelay t - return (delay, atomically $ tryWaitDelay delay) - - -- The delay times out at the right time, and after tryWaitDelay returns - -- 'True', 'updateDelay' and 'cancelDelay' have no observable effect. - (delay, wait) <- new 100000 - False <- wait - threadDelay 50000 - False <- wait - threadDelay 60000 - True <- wait - updateDelay delay 1000000 - True <- wait - updateDelay delay (-1) - True <- wait - cancelDelay delay - True <- wait - - (delay, wait) <- new 100000 - False <- wait - threadDelay 50000 - False <- wait - updateDelay delay 200000 - threadDelay 60000 - False <- wait - threadDelay 60000 - False <- wait -- updateDelay sets the timer based on the current time, - -- so the threadDelay 50000 doesn't count toward our total. - threadDelay 81000 - True <- wait - - -- 'newDelay n' where n <= 0 times out immediately, - -- rather than never timing out. - (delay, wait) <- new 0 - threadDelay 100 - True <- wait - (delay, wait) <- new (-1) - threadDelay 100 - True <- wait - - -- This fails on Windows without -threaded, as 'threadDelay minBound' - -- blocks. It also fails on Linux using GHC 7.0.3 without -threaded. -#if !mingw32_HOST_OS && MIN_VERSION_base(4,4,0) - (delay, wait) <- new minBound - threadDelay 1000 - True <- wait -#endif - - -- 'newDelay maxBound' doesn't time out any time soon, - -- and updateDelay doesn't wait for the delay to complete. - -- - -- Using maxBound currently fails on Linux 64-bit (see GHC ticket #7325), - -- so use a more lenient value for now. - -- - -- (delay, wait) <- new maxBound - (delay, wait) <- new 2147483647 - False <- wait - threadDelay 100000 - False <- wait - updateDelay delay 100000 - threadDelay 90000 - False <- wait - threadDelay 10010 - True <- wait - - -- cancelDelay causes the delay to miss its initial deadline, - -- and a subsequent updateDelay has no effect. - (delay, wait) <- new 100000 - False <- wait - threadDelay 50000 - False <- wait - cancelDelay delay - False <- wait - threadDelay 60000 - False <- wait - updateDelay delay 10000 - False <- wait - threadDelay 20000 - False <- wait - cancelDelay delay - False <- wait - threadDelay 100000 - False <- wait - - return () +{-# LANGUAGE CPP #-}++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.Delay++main = trivial++trivial = do+ let new t = do+ delay <- newDelay t+ return (delay, atomically $ tryWaitDelay delay)++ -- The delay times out at the right time, and after tryWaitDelay returns+ -- 'True', 'updateDelay' and 'cancelDelay' have no observable effect.+ (delay, wait) <- new 100000+ False <- wait+ threadDelay 50000+ False <- wait+ threadDelay 60000+ True <- wait+ updateDelay delay 1000000+ True <- wait+ updateDelay delay (-1)+ True <- wait+ cancelDelay delay+ True <- wait++ (delay, wait) <- new 100000+ False <- wait+ threadDelay 50000+ False <- wait+ updateDelay delay 200000+ threadDelay 60000+ False <- wait+ threadDelay 60000+ False <- wait -- updateDelay sets the timer based on the current time,+ -- so the threadDelay 50000 doesn't count toward our total.+ threadDelay 81000+ True <- wait++ -- 'newDelay n' where n <= 0 times out immediately,+ -- rather than never timing out.+ (delay, wait) <- new 0+ threadDelay 100+ True <- wait+ (delay, wait) <- new (-1)+ threadDelay 100+ True <- wait++ -- This fails on Windows without -threaded, as 'threadDelay minBound'+ -- blocks. It also fails on Linux using GHC 7.0.3 without -threaded.+#if !mingw32_HOST_OS && MIN_VERSION_base(4,4,0)+ (delay, wait) <- new minBound+ threadDelay 1000+ True <- wait+#endif++ -- 'newDelay maxBound' doesn't time out any time soon,+ -- and updateDelay doesn't wait for the delay to complete.+ --+ -- Using maxBound currently fails on Linux 64-bit (see GHC ticket #7325),+ -- so use a more lenient value for now.+ --+ -- (delay, wait) <- new maxBound+ (delay, wait) <- new 2147483647+ False <- wait+ threadDelay 100000+ False <- wait+ updateDelay delay 100000+ threadDelay 90000+ False <- wait+ threadDelay 10010+ True <- wait++ -- cancelDelay causes the delay to miss its initial deadline,+ -- and a subsequent updateDelay has no effect.+ (delay, wait) <- new 100000+ False <- wait+ threadDelay 50000+ False <- wait+ cancelDelay delay+ False <- wait+ threadDelay 60000+ False <- wait+ updateDelay delay 10000+ False <- wait+ threadDelay 20000+ False <- wait+ cancelDelay delay+ False <- wait+ threadDelay 100000+ False <- wait++ return ()