diff --git a/Control/Concurrent/Event.hs b/Control/Concurrent/Event.hs --- a/Control/Concurrent/Event.hs +++ b/Control/Concurrent/Event.hs @@ -68,7 +68,7 @@ import Data.Maybe ( isJust ) import Data.Typeable ( Typeable ) -#ifdef __HADDOCK__ +#ifdef __HADDOCK_VERSION__ import Control.Exception ( mask ) #endif diff --git a/Control/Concurrent/Lock.hs b/Control/Concurrent/Lock.hs --- a/Control/Concurrent/Lock.hs +++ b/Control/Concurrent/Lock.hs @@ -63,13 +63,12 @@ import Control.Applicative ( liftA2 ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, tryTakeMVar - , putMVar, tryPutMVar - , isEmptyMVar + , tryPutMVar, readMVar, isEmptyMVar ) import Control.Exception ( bracket_, onException ) -import Control.Monad ( return, (>>), when ) +import Control.Monad ( return, when ) import Data.Bool ( Bool, not ) -#ifdef __HADDOCK__ +#ifdef __HADDOCK_VERSION__ import Data.Bool ( Bool(False, True) ) #endif import Data.Eq ( Eq ) @@ -85,7 +84,7 @@ #endif -- from concurrent-extra (this package): -import Utils ( mask, mask_ ) +import Utils ( mask ) -------------------------------------------------------------------------------- @@ -198,16 +197,15 @@ * When the state is \"locked\", @wait@ /blocks/ until a call to 'release' in another thread changes it to \"unlocked\". +* @wait@ is multiple-wakeup, so when multiple waiters are blocked on a @Lock@, + all of them are woken up at the same time. + * When the state is \"unlocked\" @wait@ returns immediately. @wait@ does not alter the state of the lock. - -Note that @wait@ is just a convenience function we can be defined as: - -@wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait :: Lock -> IO () -wait (Lock mv) = mask_ $ takeMVar mv >> putMVar mv () +wait (Lock mv) = readMVar mv -------------------------------------------------------------------------------- diff --git a/Control/Concurrent/ReadWriteVar.hs b/Control/Concurrent/ReadWriteVar.hs --- a/Control/Concurrent/ReadWriteVar.hs +++ b/Control/Concurrent/ReadWriteVar.hs @@ -76,7 +76,7 @@ import Data.IORef ( IORef, newIORef, readIORef ) import Data.Typeable ( Typeable ) import System.IO ( IO ) -#ifdef __HADDOCK__ +#ifdef __HADDOCK_VERSION__ import Data.Function ( const ) import Prelude ( undefined ) #endif diff --git a/Control/Concurrent/STM/Lock.hs b/Control/Concurrent/STM/Lock.hs --- a/Control/Concurrent/STM/Lock.hs +++ b/Control/Concurrent/STM/Lock.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif @@ -52,10 +54,10 @@ -- from base: import Control.Applicative ( liftA2 ) import Control.Exception ( bracket_, onException ) -import Control.Monad ( return, (>>), when ) +import Control.Monad ( return, when ) import Data.Bool ( Bool, not ) -#ifdef __HADDOCK__ +#ifdef __HADDOCK_VERSION__ import Data.Bool ( Bool(False, True) ) #endif @@ -78,14 +80,13 @@ -- from stm: import Control.Concurrent.STM ( STM, atomically ) -#ifdef __HADDOCK__ +#ifdef __HADDOCK_VERSION__ import Control.Concurrent.STM ( retry ) #endif import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar , takeTMVar, tryTakeTMVar - , putTMVar, tryPutTMVar - , isEmptyTMVar + , tryPutTMVar, readTMVar, isEmptyTMVar ) -- from concurrent-extra (this package): @@ -189,7 +190,7 @@ @wait l = 'acquire' l '>>' 'release' l@ -} wait :: Lock -> STM () -wait (Lock tmv) = takeTMVar tmv >> putTMVar tmv () +wait (Lock tmv) = readTMVar tmv -------------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,41 +1,2 @@ -#! /usr/bin/env runhaskell - -{-# LANGUAGE NoImplicitPrelude #-} - -module Main (main) where - - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - --- from base -import System.IO ( IO ) - --- from cabal -import Distribution.Simple ( defaultMainWithHooks - , simpleUserHooks - , UserHooks(haddockHook) - ) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Program ( userSpecifyArgs ) -import Distribution.Simple.Setup ( HaddockFlags ) -import Distribution.PackageDescription ( PackageDescription(..) ) - - -------------------------------------------------------------------------------- --- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. -------------------------------------------------------------------------------- - -main :: IO () -main = defaultMainWithHooks hooks - where - hooks = simpleUserHooks { haddockHook = haddockHook' } - --- Define __HADDOCK__ for CPP when running haddock. -haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () -haddockHook' pkg lbi = - haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) - where - p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) +import Distribution.Simple +main = defaultMain diff --git a/concurrent-extra.cabal b/concurrent-extra.cabal --- a/concurrent-extra.cabal +++ b/concurrent-extra.cabal @@ -1,7 +1,7 @@ name: concurrent-extra -version: 0.7.0.10 +version: 0.7.0.11 cabal-version: >= 1.8 -build-type: Custom +build-type: Simple stability: experimental author: Bas van Dijk Roel van Dijk @@ -82,10 +82,10 @@ build-depends: base >= 3 && < 5 , stm >= 2.1.2.1 && < 2.5 , unbounded-delays >= 0.1 && < 0.2 - , HUnit >= 1.2.2 && < 1.4 + , HUnit >= 1.2.2 && < 1.7 , random >= 1.0 && < 1.2 , test-framework >= 0.2.4 && < 0.9 , test-framework-hunit >= 0.2.4 && < 0.4 - , async >= 2.0 && < 2.1 + , async >= 2.0 && < 2.2 -------------------------------------------------------------------------------