diff --git a/Control/Concurrent/Thread/Delay.hs b/Control/Concurrent/Thread/Delay.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Thread/Delay.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Thread.Delay +-- Copyright : 2011 Bas van Dijk & Roel van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- , Roel van Dijk +-- +-- Arbitrarily long thread delays. +------------------------------------------------------------------------------- + +module Control.Concurrent.Thread.Delay ( delay ) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( threadDelay ) +import Control.Monad ( when ) +import Data.Eq ( (/=) ) +import Data.Function ( ($) ) +import Data.Int ( Int ) +import Data.Ord ( min ) +import Prelude ( Integer, toInteger, fromInteger, maxBound, (-) ) +import System.IO ( IO ) + +#if __GLASGOW_HASKELL__ < 700 +import Control.Monad ( (>>) ) +#endif + + +------------------------------------------------------------------------------- +-- Delay +------------------------------------------------------------------------------- + +{-| +Like 'threadDelay', but not bounded by an 'Int'. + +Suspends the current thread for a given number of microseconds (GHC only). + +There is no guarantee that the thread will be rescheduled promptly when the +delay has expired, but the thread will never continue to run earlier than +specified. +-} +delay ∷ Integer → IO () +delay time = do + let maxWait = min time $ toInteger (maxBound ∷ Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ delay (time - maxWait) + + +-- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Timeout.hs b/Control/Concurrent/Timeout.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Timeout.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP + , DeriveDataTypeable + , NoImplicitPrelude + , UnicodeSyntax + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Timeout +-- Copyright : 2011 Bas van Dijk & Roel van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- , Roel van Dijk +-- +-- Wait arbitrarily long for an IO computation to finish. +------------------------------------------------------------------------------- + +module Control.Concurrent.Timeout ( timeout ) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( forkIO, myThreadId, throwTo, killThread ) +import Control.Exception ( Exception, bracket, handleJust ) +import Control.Monad ( return, (>>) ) +import Data.Bool ( otherwise ) +import Data.Eq ( Eq, (==) ) +import Data.Functor ( fmap ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import Data.Ord ( (<) ) +import Data.Typeable ( Typeable ) +import Data.Unique ( Unique, newUnique ) +import Prelude ( Integer ) +import System.IO ( IO ) +import Text.Show ( Show, show ) + +#if __GLASGOW_HASKELL__ < 700 +import Prelude ( fromInteger ) +import Control.Monad ( (>>=), fail ) +#endif + +#ifdef __HADDOCK__ +import Data.Int ( Int ) +import System.IO ( hGetBuf, hPutBuf, hWaitForInput ) +import qualified System.Timeout ( timeout ) +#endif + +-- from concurrent-extra (this package): +import Control.Concurrent.Thread.Delay ( delay ) + + +------------------------------------------------------------------------------- +-- Long delays and timeouts +------------------------------------------------------------------------------- + +{- +The following code was mostly copied from the module System.Timeout in the +package base-4.2.0.0. + +(c) The University of Glasgow 2007 +-} + +newtype Timeout = Timeout Unique deriving (Eq, Typeable) + +instance Show Timeout where + show _ = "<>" + +instance Exception Timeout + +{-| +Like 'System.Timeout.timeout', but not bounded by an 'Int'. + +Wrap an 'IO' computation to time out and return 'Nothing' in case no result is +available within @n@ microseconds (@1\/10^6@ seconds). In case a result is +available before the timeout expires, 'Just' @a@ is returned. A negative timeout +interval means \"wait indefinitely\". + +The design of this combinator was guided by the objective that @timeout n f@ +should behave exactly the same as @f@ as long as @f@ doesn't time out. This +means that @f@ has the same 'myThreadId' it would have without the timeout +wrapper. Any exceptions @f@ might throw cancel the timeout and propagate further +up. It also possible for @f@ to receive exceptions thrown to it by another +thread. + +A tricky implementation detail is the question of how to abort an 'IO' +computation. This combinator relies on asynchronous exceptions internally. The +technique works very well for computations executing inside of the Haskell +runtime system, but it doesn't work at all for non-Haskell code. Foreign +function calls, for example, cannot be timed out with this combinator simply +because an arbitrary C function cannot receive asynchronous exceptions. When +@timeout@ is used to wrap an FFI call that blocks, no timeout event can be +delivered until the FFI call returns, which pretty much negates the purpose of +the combinator. In practice, however, this limitation is less severe than it may +sound. Standard I\/O functions like 'System.IO.hGetBuf', 'System.IO.hPutBuf', +Network.Socket.accept, or 'System.IO.hWaitForInput' appear to be blocking, but +they really don't because the runtime system uses scheduling mechanisms like +@select(2)@ to perform asynchronous I\/O, so it is possible to interrupt +standard socket I\/O or file I\/O using this combinator. +-} +timeout ∷ Integer → IO α → IO (Maybe α) +timeout n f + | n < 0 = fmap Just f + | n == 0 = return Nothing + | otherwise = do + pid ← myThreadId + ex ← fmap Timeout newUnique + handleJust (\e → if e == ex then Just () else Nothing) + (\_ → return Nothing) + (bracket (forkIO (delay n >> throwTo pid ex)) + (killThread) + (\_ → fmap Just f) + ) + + +-- The End --------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2011 Bas van Dijk & Roel van Dijk + +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. + + * The names of Bas van Dijk, Roel van Dijk and the names of + contributors may NOT 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/unbounded-delays.cabal b/unbounded-delays.cabal new file mode 100644 --- /dev/null +++ b/unbounded-delays.cabal @@ -0,0 +1,27 @@ +name: unbounded-delays +version: 0.1 +cabal-version: >= 1.6 +build-type: Simple +author: Bas van Dijk + Roel van Dijk +maintainer: Bas van Dijk + Roel van Dijk +copyright: 2011 Bas van Dijk & Roel van Dijk +license: BSD3 +license-file: LICENSE +category: Concurrency +synopsis: Unbounded thread delays and timeouts +description: The @threadDelay@ and @timeout@ functions from the @base@ library + use the bounded @Int@ type for specifying the delay or timeout + period. This packages provides alternatives which use the + unbounded @Integer@ type. + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/unbounded-delays + +library + build-depends: base >= 3 && < 4.4 + exposed-modules: Control.Concurrent.Thread.Delay + , Control.Concurrent.Timeout + ghc-options: -Wall