diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -7,6 +7,33 @@ *de facto* standard Haskell versioning scheme. +1.2.2.0 +------- + +- **Date** 2017-11-05 +- **Git tag** [concurrency-1.2.2.0][] +- **Hackage** https://hackage.haskell.org/package/concurrency-1.2.2.0 + +### Control.Monad.Conc.Class + +- A new `IsConc` type (and `toIsConc`, `fromIsConc` functions), where a value of type `IsConc m a` + can only be constructed if `m` has a `MonadConc` instance. Its `STM` type is `IsSTM (STM m)`. + (#144) + +- The provided transformer instances now use the `modifyCRefCAS_` of the underlying monad, rather + than the default definition in terms of `modifyCRefCAS`. + +### Control.Monad.STM.Class + +- A new `IsSTM` type (and `toIsSTM`, `fromIsSTM` functions), where a value of type `IsSTM m a` can + only be constructed if `m` has a `MonadSTM` instance. (#144) + +[concurrency-1.2.2.0]: https://github.com/barrucadu/dejafu/releases/tag/concurrency-1.2.2.0 + + +--------------------------------------------------------------------------------------------------- + + 1.2.1.2 ------- diff --git a/Control/Concurrent/Classy/Async.hs b/Control/Concurrent/Classy/Async.hs --- a/Control/Concurrent/Classy/Async.hs +++ b/Control/Concurrent/Classy/Async.hs @@ -198,7 +198,7 @@ -- -- @since 1.2.1.0 asyncOnN :: MonadConc m => String -> Int -> m a -> m (Async m a) -asyncOnN name = asyncUsing . (forkOnN name) +asyncOnN name = asyncUsing . forkOnN name -- | Like 'async' but using 'forkWithUnmask' internally. -- diff --git a/Control/Monad/Conc/Class.hs b/Control/Monad/Conc/Class.hs --- a/Control/Monad/Conc/Class.hs +++ b/Control/Monad/Conc/Class.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -60,6 +61,11 @@ , cas , peekTicket + -- * Utilities for type shenanigans + , IsConc + , toIsConc + , fromIsConc + -- * Utilities for instance writers , liftedF , liftedFork @@ -71,7 +77,8 @@ import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import qualified Control.Monad.Catch as Ca -import Control.Monad.STM.Class (MonadSTM, TVar, readTVar) +import Control.Monad.STM.Class (IsSTM, MonadSTM, TVar, fromIsSTM, + readTVar) import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith) import Data.Proxy (Proxy(..)) @@ -304,9 +311,9 @@ readMVar :: MVar m a -> m a -- | Attempt to read a value from a @MVar@ non-blockingly, returning - -- a 'Just' (and emptying the @MVar@) if there is something there, - -- otherwise returning 'Nothing'. As with 'readMVar', this does not - -- \"remove\" the value. + -- a 'Just' if there is something there, otherwise returning + -- 'Nothing'. As with 'readMVar', this does not \"remove\" the + -- value. -- -- @since 1.1.0.0 tryReadMVar :: MVar m a -> m (Maybe a) @@ -658,6 +665,73 @@ IO.labelThread tid n ------------------------------------------------------------------------------- +-- Type shenanigans + +-- | A value of type @IsConc m a@ can only be constructed if @m@ has a +-- @MonadConc@ instance. +-- +-- @since 1.2.2.0 +newtype IsConc m a = IsConc { unIsConc :: m a } + deriving (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask) + +-- | Wrap an @m a@ value inside an @IsConc@ if @m@ has a @MonadConc@ +-- instance. +-- +-- @since 1.2.2.0 +toIsConc :: MonadConc m => m a -> IsConc m a +toIsConc = IsConc + +-- | Unwrap an @IsConc@ value. +-- +-- @since 1.2.2.0 +fromIsConc :: MonadConc m => IsConc m a -> m a +fromIsConc = unIsConc + +instance MonadConc m => MonadConc (IsConc m) where + type STM (IsConc m) = IsSTM (STM m) + type MVar (IsConc m) = MVar m + type CRef (IsConc m) = CRef m + type Ticket (IsConc m) = Ticket m + type ThreadId (IsConc m) = ThreadId m + + + fork ma = toIsConc (fork $ unIsConc ma) + forkOn i ma = toIsConc (forkOn i $ unIsConc ma) + + forkWithUnmask ma = toIsConc (forkWithUnmask (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx)))) + forkWithUnmaskN n ma = toIsConc (forkWithUnmaskN n (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx)))) + forkOnWithUnmask i ma = toIsConc (forkOnWithUnmask i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx)))) + forkOnWithUnmaskN n i ma = toIsConc (forkOnWithUnmaskN n i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx)))) + + getNumCapabilities = toIsConc getNumCapabilities + setNumCapabilities = toIsConc . setNumCapabilities + myThreadId = toIsConc myThreadId + yield = toIsConc yield + threadDelay = toIsConc . threadDelay + throwTo t = toIsConc . throwTo t + newEmptyMVar = toIsConc newEmptyMVar + newEmptyMVarN = toIsConc . newEmptyMVarN + readMVar = toIsConc . readMVar + tryReadMVar = toIsConc . tryReadMVar + putMVar v = toIsConc . putMVar v + tryPutMVar v = toIsConc . tryPutMVar v + takeMVar = toIsConc . takeMVar + tryTakeMVar = toIsConc . tryTakeMVar + newCRef = toIsConc . newCRef + newCRefN n = toIsConc . newCRefN n + readCRef = toIsConc . readCRef + atomicModifyCRef r = toIsConc . atomicModifyCRef r + writeCRef r = toIsConc . writeCRef r + atomicWriteCRef r = toIsConc . atomicWriteCRef r + readForCAS = toIsConc . readForCAS + peekTicket' _ = peekTicket' (Proxy :: Proxy m) + casCRef r t = toIsConc . casCRef r t + modifyCRefCAS r = toIsConc . modifyCRefCAS r + modifyCRefCAS_ r = toIsConc . modifyCRefCAS_ r + atomically = toIsConc . atomically . fromIsSTM + readTVarConc = toIsConc . readTVarConc + +------------------------------------------------------------------------------- -- Transformer instances #define INSTANCE(T,C,F) \ @@ -700,6 +774,7 @@ peekTicket' _ = peekTicket' (Proxy :: Proxy m) ; \ casCRef r t = lift . casCRef r t ; \ modifyCRefCAS r = lift . modifyCRefCAS r ; \ + modifyCRefCAS_ r = lift . modifyCRefCAS_ r ; \ atomically = lift . atomically ; \ readTVarConc = lift . readTVarConc } diff --git a/Control/Monad/STM/Class.hs b/Control/Monad/STM/Class.hs --- a/Control/Monad/STM/Class.hs +++ b/Control/Monad/STM/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -28,8 +29,14 @@ , orElse , throwSTM , catchSTM - ) where + -- * Utilities for type shenanigans + , IsSTM + , toIsSTM + , fromIsSTM +) where + +import Control.Applicative (Alternative(..)) import Control.Exception (Exception) import Control.Monad (MonadPlus(..), unless) import Control.Monad.Reader (ReaderT) @@ -144,6 +151,37 @@ newTVar = STM.newTVar readTVar = STM.readTVar writeTVar = STM.writeTVar + +------------------------------------------------------------------------------- +-- Type shenanigans + +-- | A value of type @IsSTM m a@ can only be constructed if @m@ has a +-- @MonadSTM@ instance. +-- +-- @since 1.2.2.0 +newtype IsSTM m a = IsSTM { unIsSTM :: m a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, Ca.MonadThrow, Ca.MonadCatch) + +-- | Wrap an @m a@ value inside an @IsSTM@ if @m@ has a @MonadSTM@ +-- instance. +-- +-- @since 1.2.2.0 +toIsSTM :: MonadSTM m => m a -> IsSTM m a +toIsSTM = IsSTM + +-- | Unwrap an @IsSTM@ value. +-- +-- @since 1.2.2.0 +fromIsSTM :: MonadSTM m => IsSTM m a -> m a +fromIsSTM = unIsSTM + +instance MonadSTM m => MonadSTM (IsSTM m) where + type TVar (IsSTM m) = TVar m + + newTVar = toIsSTM . newTVar + newTVarN n = toIsSTM . newTVarN n + readTVar = toIsSTM . readTVar + writeTVar v = toIsSTM . writeTVar v ------------------------------------------------------------------------------- -- Transformer instances diff --git a/concurrency.cabal b/concurrency.cabal --- a/concurrency.cabal +++ b/concurrency.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: concurrency -version: 1.2.1.2 +version: 1.2.2.0 synopsis: Typeclasses, functions, and data types for concurrency and STM. description: @@ -32,7 +32,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: concurrency-1.2.1.2 + tag: concurrency-1.2.2.0 library exposed-modules: Control.Monad.Conc.Class