stm-delay 0.1 → 0.1.1
raw patch · 5 files changed
+485/−420 lines, 5 filessetup-changed
Files
- Control/Concurrent/STM/Delay.hs +278/−217
- LICENSE +30/−30
- Setup.hs +2/−2
- stm-delay.cabal +80/−76
- test/Main.hs +95/−95
Control/Concurrent/STM/Delay.hs view
@@ -1,217 +1,278 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}--- |--- 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------ Suppose you are managing a network connection, and want to time it out if no--- messages are received in over five minutes. You can do something like this:------ >import Control.Concurrent.Async (race_) -- from the async package--- >import Control.Concurrent.STM--- >import Control.Concurrent.STM.Delay--- >import Control.Exception--- >import Control.Monad--- >--- >manageConnection :: Connection -> IO Message -> (Message -> IO a) -> IO ()--- >manageConnection conn toSend onRecv =--- > bracket (newDelay five_minutes) cancelDelay $ \delay ->--- > foldr1 race_--- > [ do atomically $ waitDelay delay--- > fail "Connection timed out"--- > , forever $ toSend >>= send conn--- > , forever $ do--- > msg <- recv conn--- > updateDelay delay five_minutes--- > onRecv msg--- > ]--- > where--- > five_minutes = 5 * 60 * 1000000-module Control.Concurrent.STM.Delay (- -- * Managing delays- Delay,- newDelay,- updateDelay,- cancelDelay,-- -- * Waiting for expiration- waitDelay,- tryWaitDelay,-) where--import Control.Applicative ((<$>))-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (mask_)-import Control.Monad (join)--#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 = forall k.- Delay !(TVar Bool)- !(DelayImpl k)- !k--instance Eq Delay where- (==) (Delay a _ _) (Delay b _ _) = a == b--type TimeoutCallback = IO ()--data DelayImpl k = DelayImpl- { delayStart :: Int -> TimeoutCallback -> IO k- , delayUpdate :: TimeoutCallback -> k -> Int -> IO ()- , delayStop :: k -> IO ()- }---- | Create a new 'Delay' that will ring in the given number of microseconds.-newDelay :: Int -> IO Delay-newDelay t = getDelayImpl (\impl -> newDelayWith impl t)--newDelayWith :: DelayImpl k -> Int -> IO Delay-newDelayWith impl t = do- var <- newTVarIO False- k <- delayStart impl t $ atomically $ writeTVar var True- return (Delay var impl k)---- | 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 (Delay var impl k) t =- delayUpdate impl (atomically $ writeTVar var True) k t---- | 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 (Delay _var impl k) =- delayStop impl k---- | 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 (Delay v _ _) = readTVar v----------------------------------------------------------------------------- Drivers--getDelayImpl :: (forall k. DelayImpl k -> IO r) -> IO r-#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS-getDelayImpl cont = do- m <- Ev.getSystemEventManager- case m of- Nothing -> cont implThread- Just mgr -> cont (implEvent mgr)-#else-getDelayImpl cont = cont implThread-#endif--#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS--- | Use the timeout API in "GHC.Event"-implEvent :: Ev.EventManager -> DelayImpl Ev.TimeoutKey-implEvent mgr = DelayImpl- { delayStart = Ev.registerTimeout mgr- , delayUpdate = \_ -> Ev.updateTimeout mgr- , delayStop = Ev.unregisterTimeout mgr- }-#endif---- | Use threads and threadDelay:------ [delayStart] Fork a thread to wait the given length of time,--- then set the TVar.------ [delayUpdate] Stop the existing thread and fork a new thread.------ [delayStop] Stop the existing thread.-implThread :: DelayImpl (MVar (Maybe TimeoutThread))-implThread = DelayImpl- { delayStart = \t io -> forkTimeoutThread t io >>= newMVar . Just- , delayUpdate = \io mv t -> replaceThread (Just <$> forkTimeoutThread t io) mv- , delayStop = replaceThread (return Nothing)- }- where- replaceThread new mv =- 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- new >>= putMVar mv- return $ case m' of- Nothing -> return ()- Just kill -> kill----------------------------------------------------------------------------- TimeoutThread--data TimeoutThread = TimeoutThread !ThreadId !(MVar ())---- instance Eq TimeoutThread where--- (==) (TimeoutThread a _) (TimeoutThread b _) = a == b--- instance Ord TimeoutThread where--- compare (TimeoutThread a _) (TimeoutThread b _) = compare a b---- | 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)) <$> 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+{-# 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. +-}
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,76 +1,80 @@-name: stm-delay-version: 0.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@.-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 +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 ()