diff --git a/Control/Concurrent/Lifted.hs b/Control/Concurrent/Lifted.hs --- a/Control/Concurrent/Lifted.hs +++ b/Control/Concurrent/Lifted.hs @@ -26,6 +26,9 @@ #if MIN_VERSION_base(4,4,0) , forkWithUnmask #endif +#if MIN_VERSION_base(4,6,0) + , forkFinally +#endif , killThread , throwTo @@ -34,6 +37,9 @@ , forkOn , forkOnWithUnmask , getNumCapabilities +#if MIN_VERSION_base(4,6,0) + , setNumCapabilities +#endif , threadCapability #endif @@ -49,19 +55,29 @@ -- * Communication abstractions , module Control.Concurrent.MVar.Lifted , module Control.Concurrent.Chan.Lifted +#if !MIN_VERSION_base(4,6,0) , module Control.Concurrent.QSem.Lifted , module Control.Concurrent.QSemN.Lifted , module Control.Concurrent.SampleVar.Lifted +#endif +#if !MIN_VERSION_base(4,6,0) -- * Merging of streams , merge , nmerge +#endif -- * Bound Threads + , C.rtsSupportsBoundThreads , forkOS , isCurrentThreadBound , runInBoundThread , runInUnboundThread + +#if MIN_VERSION_base(4,6,0) + -- * Weak references to ThreadIds + , mkWeakThreadId +#endif ) where @@ -75,7 +91,11 @@ import Data.Function ( ($) ) import System.IO ( IO ) import System.Posix.Types ( Fd ) -import Control.Exception ( Exception ) +#if MIN_VERSION_base(4,6,0) +import Control.Monad ( (>>=) ) +import Data.Either ( Either ) +import System.Mem.Weak ( Weak ) +#endif import Control.Concurrent ( ThreadId ) import qualified Control.Concurrent as C @@ -97,10 +117,16 @@ -- from lifted-base (this package): import Control.Concurrent.MVar.Lifted import Control.Concurrent.Chan.Lifted +#if !MIN_VERSION_base(4,6,0) import Control.Concurrent.QSem.Lifted import Control.Concurrent.QSemN.Lifted import Control.Concurrent.SampleVar.Lifted - +#endif +import Control.Exception.Lifted ( throwTo +#if MIN_VERSION_base(4,6,0) + , SomeException, try, mask +#endif + ) #include "inlinable.h" @@ -132,19 +158,29 @@ forkWithUnmask f = liftBaseWith $ \runInIO → C.forkIOWithUnmask $ \unmask → void $ runInIO $ f $ liftBaseOp_ unmask -{-# INLINABLE forkWithUnmask #-} +{-# INLINABLE forkWithUnmask #-} #endif +#if MIN_VERSION_base(4,6,0) +-- | Generalized version of 'C.forkFinally'. +-- +-- Note that in @forkFinally action and_then@, while the forked +-- @action@ and the @and_then@ function have access to the captured +-- state, all their side-effects in @m@ are discarded. They're run +-- only for their side-effects in 'IO'. +forkFinally ∷ MonadBaseControl IO m + ⇒ m a → (Either SomeException a → m ()) → m ThreadId +forkFinally action and_then = + mask $ \restore -> + fork $ try (restore action) >>= and_then +{-# INLINABLE forkFinally #-} +#endif + -- | Generalized version of 'C.killThread'. killThread ∷ MonadBase IO m ⇒ ThreadId → m () killThread = liftBase ∘ C.killThread {-# INLINABLE killThread #-} --- | Generalized version of 'C.throwTo'. -throwTo ∷ (MonadBase IO m, Exception e) ⇒ ThreadId → e → m () -throwTo tid e = liftBase $ C.throwTo tid e -{-# INLINABLE throwTo #-} - #if MIN_VERSION_base(4,4,0) -- | Generalized version of 'C.forkOn'. -- @@ -171,6 +207,13 @@ getNumCapabilities = liftBase C.getNumCapabilities {-# INLINABLE getNumCapabilities #-} +#if MIN_VERSION_base(4,6,0) +-- | Generalized version of 'C.setNumCapabilities'. +setNumCapabilities ∷ MonadBase IO m ⇒ Int → m () +setNumCapabilities = liftBase ∘ C.setNumCapabilities +{-# INLINABLE setNumCapabilities #-} +#endif + -- | Generalized version of 'C.threadCapability'. threadCapability ∷ MonadBase IO m ⇒ ThreadId → m (Int, Bool) threadCapability = liftBase ∘ C.threadCapability @@ -197,6 +240,7 @@ threadWaitWrite = liftBase ∘ C.threadWaitWrite {-# INLINABLE threadWaitWrite #-} +#if !MIN_VERSION_base(4,6,0) -- | Generalized version of 'C.mergeIO'. merge ∷ MonadBase IO m ⇒ [a] → [a] → m [a] merge xs ys = liftBase $ C.mergeIO xs ys @@ -206,6 +250,7 @@ nmerge ∷ MonadBase IO m ⇒ [[a]] → m [a] nmerge = liftBase ∘ C.nmergeIO {-# INLINABLE nmerge #-} +#endif -- | Generalized version of 'C.forkOS'. -- @@ -230,3 +275,10 @@ runInUnboundThread ∷ MonadBaseControl IO m ⇒ m a → m a runInUnboundThread = liftBaseOp_ C.runInUnboundThread {-# INLINABLE runInUnboundThread #-} + +#if MIN_VERSION_base(4,6,0) +-- | Generalized versio of 'C.mkWeakThreadId'. +mkWeakThreadId ∷ MonadBase IO m ⇒ ThreadId → m (Weak ThreadId) +mkWeakThreadId = liftBase ∘ C.mkWeakThreadId +{-# INLINABLE mkWeakThreadId #-} +#endif diff --git a/Control/Concurrent/MVar/Lifted.hs b/Control/Concurrent/MVar/Lifted.hs --- a/Control/Concurrent/MVar/Lifted.hs +++ b/Control/Concurrent/MVar/Lifted.hs @@ -35,7 +35,15 @@ , withMVar , modifyMVar_ , modifyMVar +#if MIN_VERSION_base(4,6,0) + , modifyMVarMasked_ + , modifyMVarMasked +#endif +#if MIN_VERSION_base(4,6,0) + , mkWeakMVar +#else , addMVarFinalizer +#endif ) where @@ -60,6 +68,9 @@ , block, unblock #endif ) +#if MIN_VERSION_base(4,6,0) +import System.Mem.Weak ( Weak ) +#endif #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), (>>), fail ) @@ -143,7 +154,7 @@ modifyMVar ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m (a, b)) → m b #if MIN_VERSION_base(4,3,0) -modifyMVar mv f = control $ \runInIO -> mask $ \restore → do +modifyMVar mv f = control $ \runInIO → mask $ \restore → do aborted ← newIORef True let f' x = do (x', a) ← f x @@ -173,6 +184,39 @@ #endif {-# INLINABLE modifyMVar #-} +#if MIN_VERSION_base(4,6,0) +-- | Generalized version of 'MVar.modifyMVarMasked_'. +modifyMVarMasked_ ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m a) → m () +modifyMVarMasked_ mv = modifyMVarMasked mv ∘ (fmap (, ()) ∘) +{-# INLINABLE modifyMVarMasked_ #-} + +-- | Generalized version of 'MVar.modifyMVarMasked'. +modifyMVarMasked ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m (a, b)) → m b +modifyMVarMasked mv f = control $ \runInIO → mask_ $ do + aborted ← newIORef True + let f' x = do + (x', a) ← f x + liftBase $ do + writeIORef aborted False + MVar.putMVar mv x' + return a + x ← MVar.takeMVar mv + stM ← runInIO (f' x) `onException` MVar.putMVar mv x + abort ← readIORef aborted + when abort $ MVar.putMVar mv x + return stM +{-# INLINABLE modifyMVarMasked #-} +#endif + +#if MIN_VERSION_base(4,6,0) +-- | Generalized version of 'MVar.mkWeakMVar'. +-- +-- Note any monadic side effects in @m@ of the \"finalizer\" computation are +-- discarded. +mkWeakMVar ∷ MonadBaseControl IO m ⇒ MVar a → m () → m (Weak (MVar a)) +mkWeakMVar = liftBaseDiscard ∘ MVar.mkWeakMVar +{-# INLINABLE mkWeakMVar #-} +#else -- | Generalized version of 'MVar.addMVarFinalizer'. -- -- Note any monadic side effects in @m@ of the \"finalizer\" computation are @@ -180,3 +224,4 @@ addMVarFinalizer ∷ MonadBaseControl IO m ⇒ MVar a → m () → m () addMVarFinalizer = liftBaseDiscard ∘ MVar.addMVarFinalizer {-# INLINABLE addMVarFinalizer #-} +#endif diff --git a/Control/Exception/Lifted.hs b/Control/Exception/Lifted.hs --- a/Control/Exception/Lifted.hs +++ b/Control/Exception/Lifted.hs @@ -30,7 +30,7 @@ ( module Control.Exception -- * Throwing exceptions - , throwIO, ioError + , throwIO, ioError, throwTo -- * Catching exceptions -- ** The @catch@ functions @@ -53,6 +53,9 @@ , mask, mask_ , uninterruptibleMask, uninterruptibleMask_ , getMaskingState +#if MIN_VERSION_base(4,4,0) + , allowInterrupt +#endif #else , block, unblock #endif @@ -85,7 +88,7 @@ #endif import Control.Exception hiding - ( throwIO, ioError + ( throwIO, ioError, throwTo , catch, catches, Handler(..), catchJust , handle, handleJust , try, tryJust @@ -94,6 +97,9 @@ , mask, mask_ , uninterruptibleMask, uninterruptibleMask_ , getMaskingState +#if MIN_VERSION_base(4,4,0) + , allowInterrupt +#endif #else , block, unblock #endif @@ -103,7 +109,9 @@ , bracket, bracket_, bracketOnError , finally, onException ) -import qualified Control.Exception as E +import qualified Control.Exception as E +import qualified Control.Concurrent as C +import Control.Concurrent ( ThreadId ) #if !MIN_VERSION_base(4,4,0) import Data.Bool ( Bool ) @@ -140,6 +148,10 @@ ioError = liftBase ∘ E.ioError {-# INLINABLE ioError #-} +-- | Generalized version of 'C.throwTo'. +throwTo ∷ (MonadBase IO m, Exception e) ⇒ ThreadId → e → m () +throwTo tid e = liftBase $ C.throwTo tid e +{-# INLINABLE throwTo #-} -------------------------------------------------------------------------------- -- * Catching exceptions @@ -263,6 +275,13 @@ getMaskingState ∷ MonadBase IO m ⇒ m MaskingState getMaskingState = liftBase E.getMaskingState {-# INLINABLE getMaskingState #-} + +#if MIN_VERSION_base(4,4,0) +-- |Generalized version of 'E.allowInterrupt'. +allowInterrupt ∷ MonadBase IO m ⇒ m () +allowInterrupt = liftBase E.allowInterrupt +{-# INLINABLE allowInterrupt #-} +#endif #else -- |Generalized version of 'E.block'. block ∷ MonadBaseControl IO m ⇒ m a → m a diff --git a/Data/IORef/Lifted.hs b/Data/IORef/Lifted.hs --- a/Data/IORef/Lifted.hs +++ b/Data/IORef/Lifted.hs @@ -25,7 +25,13 @@ , readIORef , writeIORef , modifyIORef +#if MIN_VERSION_base(4,6,0) + , modifyIORef' +#endif , atomicModifyIORef +#if MIN_VERSION_base(4,6,0) + , atomicModifyIORef' +#endif , mkWeakIORef ) where @@ -79,6 +85,18 @@ atomicModifyIORef r = liftBase ∘ R.atomicModifyIORef r {-# INLINABLE atomicModifyIORef #-} +#if MIN_VERSION_base(4,6,0) +-- | Generalized version of 'R.modifyIORef''. +modifyIORef' ∷ MonadBase IO m ⇒ IORef a → (a → a) → m () +modifyIORef' r = liftBase ∘ R.modifyIORef' r +{-# INLINABLE modifyIORef' #-} + +-- | Generalized version of 'R.atomicModifyIORef''. +atomicModifyIORef' ∷ MonadBase IO m ⇒ IORef a → (a → (a, b)) → m b +atomicModifyIORef' r = liftBase ∘ R.atomicModifyIORef' r +{-# INLINABLE atomicModifyIORef' #-} +#endif + -- | Generalized version of 'R.mkWeakIORef'. -- -- Note any monadic side effects in @m@ of the \"finalizer\" computation @@ -86,4 +104,3 @@ mkWeakIORef ∷ MonadBaseControl IO m ⇒ IORef a → m () → m (Weak (IORef a)) mkWeakIORef = liftBaseDiscard ∘ R.mkWeakIORef {-# INLINABLE mkWeakIORef #-} - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright © 2010, Bas van Dijk, Anders Kaseorg +Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/lifted-base.cabal b/lifted-base.cabal --- a/lifted-base.cabal +++ b/lifted-base.cabal @@ -1,11 +1,11 @@ Name: lifted-base -Version: 0.1.2 +Version: 0.2 Synopsis: lifted IO operations from the base library License: BSD3 License-file: LICENSE Author: Bas van Dijk, Anders Kaseorg Maintainer: Bas van Dijk -Copyright: (c) 2011 Bas van Dijk, Anders Kaseorg +Copyright: (c) 2011-2012 Bas van Dijk, Anders Kaseorg Homepage: https://github.com/basvandijk/lifted-base Bug-reports: https://github.com/basvandijk/lifted-base/issues Category: Control @@ -37,12 +37,14 @@ Exposed-modules: Control.Exception.Lifted Control.Concurrent.MVar.Lifted Control.Concurrent.Chan.Lifted - Control.Concurrent.QSem.Lifted - Control.Concurrent.QSemN.Lifted - Control.Concurrent.SampleVar.Lifted Control.Concurrent.Lifted Data.IORef.Lifted System.Timeout.Lifted + if impl(ghc < 7.6) + Exposed-modules: + Control.Concurrent.QSem.Lifted + Control.Concurrent.QSemN.Lifted + Control.Concurrent.SampleVar.Lifted Build-depends: base >= 3 && < 4.7 , base-unicode-symbols >= 0.1.1 && < 0.3