Initial import

Ignore-this: 346106360864253530161f60718d8067

darcs-hash:20110327115243-ae560-5ac754c1efb1d59daa78a8ea1a284535d8b65dfe.gz

Control/Concurrent/Thread/Delay.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}
+
+-------------------------------------------------------------------------------
+-- |
+-- Module     : Control.Concurrent.Thread.Delay
+-- Copyright  : (c) 2011 Bas van Dijk & Roel van Dijk
+-- License    : BSD3 (see the file LICENSE)
+-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
+--            , Roel van Dijk <vandijk.roel@gmail.com>
+--
+-- Arbitrarily long thread delays.
+-------------------------------------------------------------------------------
+
+module Control.Concurrent.Thread.Delay ( delay ) where
+
+
+-------------------------------------------------------------------------------
+-- Imports
+-------------------------------------------------------------------------------
+
+-- from base:
+import Control.Concurrent ( threadDelay )
+import Control.Monad      ( when )
+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
+
+-- from base-unicode-symbols:
+import Data.Eq.Unicode    ( (≢) )
+
+
+-------------------------------------------------------------------------------
+-- 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 ---------------------------------------------------------------------

Control/Concurrent/Timeout.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE CPP
+           , DeriveDataTypeable
+           , NoImplicitPrelude
+           , UnicodeSyntax
+  #-}
+
+-------------------------------------------------------------------------------
+-- |
+-- Module     : Control.Concurrent.Timeout
+-- Copyright  : (c) 2011 Bas van Dijk & Roel van Dijk
+-- License    : BSD3 (see the file LICENSE)
+-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
+--            , Roel van Dijk <vandijk.roel@gmail.com>
+--
+-- 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 base-unicode-symbols:
+import Data.Eq.Unicode          ( (≡) )
+
+-- 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 _ = "<<timeout>>"
+
+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 ---------------------------------------------------------------------

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.

unbounded-delays.cabal

@@ -0,0 +1,30 @@
+name:          unbounded-delays
+version:       0.1
+cabal-version: >= 1.6
+build-type:    Simple
+author:        Bas van Dijk <v.dijk.bas@gmail.com>
+               Roel van Dijk <vandijk.roel@gmail.com>
+maintainer:    Bas van Dijk <v.dijk.bas@gmail.com>
+               Roel van Dijk <vandijk.roel@gmail.com>
+copyright:     (c) 2011 Bas van Dijk & Roel van Dijk
+license:       BSD3
+license-file:  LICENSE
+category:      Concurrency
+synopsis:      Arbitrarily long thread delays and timeouts
+description:
+  This package provides:
+  .
+  * @Thread.Delay@: Arbitrarily long thread delays.
+  .
+  * @Timeout@: Wait arbitrarily long for an IO computation to finish.
+
+source-repository head
+  Type: darcs
+  Location: http://code.haskell.org/~basvandijk/code/unbounded-delays
+
+library
+  build-depends: base                 >= 3     && < 4.4
+               , base-unicode-symbols >= 0.1.1 && < 0.3
+  exposed-modules: Control.Concurrent.Thread.Delay
+                 , Control.Concurrent.Timeout
+  ghc-options: -Wall