packages feed

concurrency (empty) → 1.0.0.0

raw patch · 18 files changed

+2091/−0 lines, 18 filesdep +arraydep +atomic-primopsdep +basesetup-changed

Dependencies added: array, atomic-primops, base, exceptions, monad-control, mtl, stm, transformers

Files

+ Control/Concurrent/Classy.hs view
@@ -0,0 +1,40 @@+-- |+-- Module      : Control.Concurrent.Classy+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : experimental+-- Portability : non-portable+--+-- Classy concurrency.+--+-- Concurrency is \"lightweight\", which means that both thread+-- creation and context switching overheads are extremely+-- low. Scheduling of Haskell threads is done internally in the+-- Haskell runtime system, and doesn't make use of any operating+-- system-supplied thread packages.+--+-- Haskell threads can communicate via @MVar@s, a kind of synchronised+-- mutable variable (see "Control.Concurrent.Classy.MVar"). Several+-- common concurrency abstractions can be built from @MVar@s, and+-- these are provided by the "Control.Concurrent.Classy"+-- library. Threads may also communicate via exceptions.+module Control.Concurrent.Classy+  ( module Control.Monad.Conc.Class+  , module Control.Concurrent.Classy.Chan+  , module Control.Concurrent.Classy.CRef+  , module Control.Concurrent.Classy.MVar+  , module Control.Concurrent.Classy.STM+  , module Control.Concurrent.Classy.QSem+  , module Control.Concurrent.Classy.QSemN+  ) where++import Control.Monad.Conc.Class+import Control.Concurrent.Classy.Chan+import Control.Concurrent.Classy.CRef+import Control.Concurrent.Classy.MVar+import Control.Concurrent.Classy.STM+import Control.Concurrent.Classy.QSem+import Control.Concurrent.Classy.QSemN++{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
+ Control/Concurrent/Classy/CRef.hs view
@@ -0,0 +1,114 @@+-- |+-- Module      : Control.Concurrent.Classy.CRef+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Mutable references in a concurrency monad.+--+-- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the+-- @CRef@ type. Furthermore, the @mkWeakIORef@ function is not+-- provided.+module Control.Concurrent.Classy.CRef+  ( -- * CRefs+    newCRef+  , readCRef+  , writeCRef+  , modifyCRef+  , modifyCRef'+  , atomicModifyCRef+  , atomicModifyCRef'+  , atomicWriteCRef++  -- * Memory Model++  -- | In a concurrent program, @CRef@ operations may appear+  -- out-of-order to another thread, depending on the memory model of+  -- the underlying processor architecture. For example, on x86 (which+  -- uses total store order), loads can move ahead of stores. Consider+  -- this example:+  --+  -- > crefs :: MonadConc m => m (Bool, Bool)+  -- > crefs = do+  -- >   r1 <- newCRef False+  -- >   r2 <- newCRef False+  -- >+  -- >   x <- spawn $ writeCRef r1 True >> readCRef r2+  -- >   y <- spawn $ writeCRef r2 True >> readCRef r1+  -- >+  -- >   (,) <$> readMVar x <*> readMVar y+  --+  -- Under a sequentially consistent memory model the possible results+  -- are @(True, True)@, @(True, False)@, and @(False, True)@. Under+  -- total or partial store order, @(False, False)@ is also a possible+  -- result, even though there is no interleaving of the threads which+  -- can lead to this.+  --+  -- We can see this by testing with different memory models:+  --+  -- > > autocheck' SequentialConsistency crefs+  -- > [pass] Never Deadlocks (checked: 6)+  -- > [pass] No Exceptions (checked: 6)+  -- > [fail] Consistent Result (checked: 5)+  -- >         (False,True) S0-------S1-----S0--S2-----S0---+  -- >         (True,False) S0-------S1-P2-----S1----S0----+  -- >         (True,True) S0-------S1--P2-----S1---S0----+  -- >         (False,True) S0-------S1---P2-----S1--S0----+  -- >         (True,False) S0-------S2-----S1-----S0----+  -- >         ...+  -- > False+  --+  -- > > autocheck' TotalStoreOrder crefs+  -- > [pass] Never Deadlocks (checked: 303)+  -- > [pass] No Exceptions (checked: 303)+  -- > [fail] Consistent Result (checked: 302)+  -- >         (False,True) S0-------S1-----C-S0--S2-----C-S0---+  -- >         (True,False) S0-------S1-P2-----C-S1----S0----+  -- >         (True,True) S0-------S1-P2--C-S1----C-S0--S2---S0---+  -- >         (False,True) S0-------S1-P2--P1--C-C-S1--S0--S2---S0---+  -- >         (False,False) S0-------S1-P2--P1----S2---C-C-S0----+  -- >         ...+  -- > False+  --+  -- Traces for non-sequentially-consistent memory models show where+  -- writes to @CRef@s are /committed/, which makes a write visible to+  -- all threads rather than just the one which performed the+  -- write. Only 'writeCRef' is broken up into separate write and+  -- commit steps, 'atomicModifyCRef' is still atomic and imposes a+  -- memory barrier.+  ) where++import Control.Monad.Conc.Class++-- | Mutate the contents of a @CRef@.+--+-- Be warned that 'modifyCRef' does not apply the function strictly.+-- This means if the program calls 'modifyCRef' many times, but+-- seldomly uses the value, thunks will pile up in memory resulting in+-- a space leak. This is a common mistake made when using a @CRef@ as+-- a counter. For example, the following will likely produce a stack+-- overflow:+--+-- >ref <- newCRef 0+-- >replicateM_ 1000000 $ modifyCRef ref (+1)+-- >readCRef ref >>= print+--+-- To avoid this problem, use 'modifyCRef'' instead.+modifyCRef :: MonadConc m => CRef m a -> (a -> a) -> m ()+modifyCRef ref f = readCRef ref >>= writeCRef ref . f++-- | Strict version of 'modifyCRef'+modifyCRef' :: MonadConc m => CRef m a -> (a -> a) -> m ()+modifyCRef' ref f = do+  x <- readCRef ref+  writeCRef ref $! f x++-- | Strict version of 'atomicModifyCRef'. This forces both the value+-- stored in the @CRef@ as well as the value returned.+atomicModifyCRef' :: MonadConc m => CRef m a -> (a -> (a,b)) -> m b+atomicModifyCRef' ref f = do+  b <- atomicModifyCRef ref $ \a -> case f a of+    v@(a',_) -> a' `seq` v+  pure $! b
+ Control/Concurrent/Classy/Chan.hs view
@@ -0,0 +1,79 @@+-- |+-- Module      : Control.Concurrent.Classy.Chan+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Unbounded channels.+--+-- __Deviations:__ @Chan@ as defined here does not have an @Eq@+-- instance, this is because the @MonadConc@ @MVar@ type does not have+-- an @Eq@ constraint. The deprecated @unGetChan@ and @isEmptyCHan@+-- functions are not provided. Furthermore, the @getChanContents@+-- function is not provided as it needs unsafe I/O.+module Control.Concurrent.Classy.Chan+  ( -- * The 'Chan' type+    Chan++  -- * Operations+  , newChan+  , writeChan+  , readChan+  , dupChan++  -- * Stream interface+  , writeList2Chan+  ) where++import Control.Concurrent.Classy.MVar+import Control.Monad.Catch (mask_)+import Control.Monad.Conc.Class (MonadConc)++-- | 'Chan' is an abstract type representing an unbounded FIFO+-- channel.+data Chan m a+  = Chan (MVar m (Stream m a))+         (MVar m (Stream m a)) -- Invariant: the Stream a is always an empty MVar++type Stream m a = MVar m (ChItem m a)++data ChItem m a = ChItem a (Stream m a)++-- | Build and returns a new instance of 'Chan'.+newChan :: MonadConc m => m (Chan m a)+newChan = do+  hole  <- newEmptyMVar+  readVar  <- newMVar hole+  writeVar <- newMVar hole+  pure (Chan readVar writeVar)++-- | Write a value to a 'Chan'.+writeChan :: MonadConc m => Chan m a -> a -> m ()+writeChan (Chan _ writeVar) val = do+  new_hole <- newEmptyMVar+  mask_ $ do+    old_hole <- takeMVar writeVar+    putMVar old_hole (ChItem val new_hole)+    putMVar writeVar new_hole++-- | Read the next value from the 'Chan'.+readChan :: MonadConc m => Chan m a -> m a+readChan (Chan readVar _) =  modifyMVarMasked readVar $ \read_end -> do+  (ChItem val new_read_end) <- readMVar read_end+  pure (new_read_end, val)++-- | Duplicate a 'Chan': the duplicate channel begins empty, but data+-- written to either channel from then on will be available from both.+-- Hence this creates a kind of broadcast channel, where data written+-- by anyone is seen by everyone else.+dupChan :: MonadConc m => Chan m a -> m (Chan m a)+dupChan (Chan _ writeVar) = do+  hole       <- readMVar writeVar+  newReadVar <- newMVar hole+  pure (Chan newReadVar writeVar)++-- | Write an entire list of items to a 'Chan'.+writeList2Chan :: MonadConc m => Chan m a -> [a] -> m ()+writeList2Chan = mapM_ . writeChan
+ Control/Concurrent/Classy/MVar.hs view
@@ -0,0 +1,128 @@+-- |+-- Module      : Control.Concurrent.Classy.MVar+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- An @'MVar' t@ is mutable location that is either empty or contains+-- a value of type @t@.  It has two fundamental operations: 'putMVar'+-- which fills an 'MVar' if it is empty and blocks otherwise, and+-- 'takeMVar' which empties an 'MVar' if it is full and blocks+-- otherwise.  They can be used in multiple different ways:+--+--   1. As synchronized mutable variables,+--+--   2. As channels, with 'takeMVar' and 'putMVar' as receive and+--      send, and+--+--   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and+--      'putMVar' as wait and signal.+--+-- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the+-- @MVar@ type. Furthermore, the @mkWeakMVar@ and @addMVarFinalizer@+-- functions are not provided. Finally, normal @MVar@s have a fairness+-- guarantee, which dejafu does not currently make use of when+-- generating schedules to test, so your program may be tested with+-- /unfair/ schedules.+module Control.Concurrent.Classy.MVar+ ( -- *@MVar@s+  MVar+ , newEmptyMVar+ , newEmptyMVarN+ , newMVar+ , newMVarN+ , takeMVar+ , putMVar+ , readMVar+ , swapMVar+ , tryTakeMVar+ , tryPutMVar+ , isEmptyMVar+ , withMVar+ , withMVarMasked+ , modifyMVar_+ , modifyMVar+ , modifyMVarMasked_+ , modifyMVarMasked+ ) where++import Control.Monad.Catch (mask_, onException)+import Control.Monad.Conc.Class++-- | Swap the contents of a @MVar@, and return the value taken. This+-- function is atomic only if there are no other producers fro this+-- @MVar@.+swapMVar :: MonadConc m => MVar m a -> a -> m a+swapMVar cvar a = mask_ $ do+  old <- takeMVar cvar+  putMVar cvar a+  return old++-- | Check if a @MVar@ is empty.+isEmptyMVar :: MonadConc m => MVar m a -> m Bool+isEmptyMVar cvar = do+  val <- tryTakeMVar cvar+  case val of+    Just val' -> putMVar cvar val' >> return True+    Nothing   -> return False++-- | Operate on the contents of a @MVar@, replacing the contents after+-- finishing. This operation is exception-safe: it will replace the+-- original contents of the @MVar@ if an exception is raised. However,+-- it is only atomic if there are no other producers for this @MVar@.+{-# INLINE withMVar #-}+withMVar :: MonadConc m => MVar m a -> (a -> m b) -> m b+withMVar cvar f = mask $ \restore -> do+  val <- takeMVar cvar+  out <- restore (f val) `onException` putMVar cvar val+  putMVar cvar val++  return out++-- | Like 'withMVar', but the @IO@ action in the second argument is+-- executed with asynchronous exceptions masked.+{-# INLINE withMVarMasked #-}+withMVarMasked :: MonadConc m => MVar m a -> (a -> m b) -> m b+withMVarMasked cvar f = mask_ $ do+  val <- takeMVar cvar+  out <- f val `onException` putMVar cvar val+  putMVar cvar val++  return out++-- | An exception-safe wrapper for modifying the contents of a @MVar@.+-- Like 'withMVar', 'modifyMVar' will replace the original contents of+-- the @MVar@ if an exception is raised during the operation. This+-- function is only atomic if there are no other producers for this+-- @MVar@.+{-# INLINE modifyMVar_ #-}+modifyMVar_ :: MonadConc m => MVar m a -> (a -> m a) -> m ()+modifyMVar_ cvar f = modifyMVar cvar $ fmap (\a -> (a,())) . f++-- | A slight variation on 'modifyMVar_' that allows a value to be+-- returned (@b@) in addition to the modified value of the @MVar@.+{-# INLINE modifyMVar #-}+modifyMVar :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b+modifyMVar cvar f = mask $ \restore -> do+  val <- takeMVar cvar+  (val', out) <- restore (f val) `onException` putMVar cvar val+  putMVar cvar val'+  return out++-- | Like 'modifyMVar_', but the @IO@ action in the second argument is+-- executed with asynchronous exceptions masked.+{-# INLINE modifyMVarMasked_ #-}+modifyMVarMasked_ :: MonadConc m => MVar m a -> (a -> m a) -> m ()+modifyMVarMasked_ cvar f = modifyMVarMasked cvar $ fmap (\a -> (a,())) . f++-- | Like 'modifyMVar', but the @IO@ action in the second argument is+-- executed with asynchronous exceptions masked.+{-# INLINE modifyMVarMasked #-}+modifyMVarMasked :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b+modifyMVarMasked cvar f = mask_ $ do+  val <- takeMVar cvar+  (val', out) <- f val `onException` putMVar cvar val+  putMVar cvar val'+  return out
+ Control/Concurrent/Classy/QSem.hs view
@@ -0,0 +1,45 @@+-- |+-- Module      : Control.Concurrent.Classy.QSem+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Simple quantity semaphores.+module Control.Concurrent.Classy.QSem+  ( -- * Simple Quantity Semaphores+    QSem+  , newQSem+  , waitQSem+  , signalQSem+  ) where++import Control.Concurrent.Classy.QSemN+import Control.Monad.Conc.Class (MonadConc)++-- | @QSem@ is a quantity semaphore in which the resource is acquired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked 'waitQSem' calls.+--+-- The pattern+--+-- > bracket_ qaitQSem signalSSem (...)+--+-- is safe; it never loses a unit of the resource.+newtype QSem m = QSem (QSemN m)++-- | Build a new 'QSem' with a supplied initial quantity. The initial+-- quantity must be at least 0.+newQSem :: MonadConc m => Int -> m (QSem m)+newQSem initial+  | initial < 0 = fail "newQSem: Initial quantity mus tbe non-negative."+  | otherwise   = QSem <$> newQSemN initial++-- | Wait for a unit to become available.+waitQSem :: MonadConc m => QSem m -> m ()+waitQSem (QSem qSemN) = waitQSemN qSemN 1++-- | Signal that a unit of the 'QSem' is available.+signalQSem :: MonadConc m => QSem m -> m ()+signalQSem (QSem qSemN) = signalQSemN qSemN 1
+ Control/Concurrent/Classy/QSemN.hs view
@@ -0,0 +1,97 @@+-- |+-- Module      : Control.Concurrent.Classy.QSemN+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Quantity semaphores in which each thread may wait for an arbitrary+-- \"amount\".+module Control.Concurrent.Classy.QSemN+  ( -- * General Quantity Semaphores+    QSemN+  , newQSemN+  , waitQSemN+  , signalQSemN+  ) where++import Control.Monad.Conc.Class (MonadConc)+import Control.Concurrent.Classy.MVar+import Control.Monad.Catch (mask_, onException, uninterruptibleMask_)+import Data.Maybe++-- | 'QSemN' is a quantity semaphore in which the resource is aqcuired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSemN` calls.+--+-- The pattern+--+-- > bracket_ (waitQSemN n) (signalQSemN n) (...)+--+-- is safe; it never loses any of the resource.+newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())]))++-- | Build a new 'QSemN' with a supplied initial quantity.+--  The initial quantity must be at least 0.+newQSemN :: MonadConc m => Int -> m (QSemN m)+newQSemN initial+  | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"+  | otherwise   = QSemN <$> newMVar (initial, [], [])++-- | Wait for the specified quantity to become available+waitQSemN :: MonadConc m => QSemN m -> Int -> m ()+waitQSemN (QSemN m) sz = mask_ $ do+  (quantity, b1, b2) <- takeMVar m+  let remaining = quantity - sz+  if remaining < 0+  -- Enqueue and block the thread+  then do+    b <- newEmptyMVar+    putMVar m (quantity, b1, (sz,b):b2)+    wait b+  -- Claim the resource+  else+    putMVar m (remaining, b1, b2)++  where+    wait b = takeMVar b `onException` uninterruptibleMask_ (do+      (quantity, b1, b2) <- takeMVar m+      r  <- tryTakeMVar b+      r' <- if isJust r+           then signal sz (quantity, b1, b2)+           else putMVar b () >> pure (quantity, b1, b2)+      putMVar m r')++-- | Signal that a given quantity is now available from the 'QSemN'.+signalQSemN :: MonadConc m => QSemN m -> Int -> m ()+signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do+  r  <- takeMVar m+  r' <- signal sz r+  putMVar m r'++-- | Fix the queue and signal as many threads as we can.+signal :: MonadConc m+  => Int+  -> (Int, [(Int,MVar m ())], [(Int,MVar m ())])+  -> m (Int, [(Int,MVar m ())], [(Int,MVar m ())])+signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2 where+  -- No more resource left, done.+  loop 0 bs b2 = pure (0,  bs, b2)++  -- Fix the queue+  loop sz [] [] = pure (sz, [], [])+  loop sz [] b2 = loop sz (reverse b2) []++  -- Signal as many threads as there is enough resource to satisfy,+  -- stopping as soon as one thread requires more resource than there+  -- is.+  loop sz ((j,b):bs) b2+    | j > sz = do+      r <- isEmptyMVar b+      if r then pure (sz, (j,b):bs, b2)+           else loop sz bs b2+    | otherwise = do+      r <- tryPutMVar b ()+      if r then loop (sz-j) bs b2+           else loop sz bs b2
+ Control/Concurrent/Classy/STM.hs view
@@ -0,0 +1,28 @@+-- |+-- Module      : Control.Concurrent.Classy.STM+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : experimental+-- Portability : non-portable+--+-- Classy software transactional memory.+module Control.Concurrent.Classy.STM+  ( module Control.Monad.STM.Class+  , module Control.Concurrent.Classy.STM.TVar+  , module Control.Concurrent.Classy.STM.TMVar+  , module Control.Concurrent.Classy.STM.TChan+  , module Control.Concurrent.Classy.STM.TQueue+  , module Control.Concurrent.Classy.STM.TBQueue+  , module Control.Concurrent.Classy.STM.TArray+  ) where++import Control.Monad.STM.Class+import Control.Concurrent.Classy.STM.TVar+import Control.Concurrent.Classy.STM.TMVar+import Control.Concurrent.Classy.STM.TChan+import Control.Concurrent.Classy.STM.TQueue+import Control.Concurrent.Classy.STM.TBQueue+import Control.Concurrent.Classy.STM.TArray++{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
+ Control/Concurrent/Classy/STM/TArray.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-- |+-- Module      : Control.Concurrent.Classy.STM.+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : FlexibleInstances, MultiParamTypeClasses+--+-- TArrays: transactional arrays, for use in STM-like monads.+--+-- __Deviations:__ @TArray@ as defined here does not have an @Eq@+-- instance, this is because the @MonadSTM@ @TVar@ type does not have+-- an @Eq@ constraint.+module Control.Concurrent.Classy.STM.TArray (TArray) where++import Data.Array (Array, bounds)+import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..),+                        IArray(numElements))+import Data.Ix (rangeSize)++import Control.Monad.STM.Class++-- | @TArray@ is a transactional array, supporting the usual 'MArray'+-- interface for mutable arrays.+--+-- It is currently implemented as @Array ix (TVar stm e)@, but it may+-- be replaced by a more efficient implementation in the future (the+-- interface will remain the same, however).+newtype TArray stm i e = TArray (Array i (TVar stm e))++instance MonadSTM stm => MArray (TArray stm) e stm where+  getBounds (TArray a) = pure (bounds a)++  newArray b e = do+    a <- rep (rangeSize b) (newTVar e)+    pure $ TArray (listArray b a)++  newArray_ b = newArray b arrEleBottom++  unsafeRead  (TArray a) = readTVar  . unsafeAt a+  unsafeWrite (TArray a) = writeTVar . unsafeAt a++  getNumElements (TArray a) = pure (numElements a)++-- | Like 'replicateM' but uses an accumulator to prevent stack overflows.+-- Unlike 'replicateM' the returned list is in reversed order.  This+-- doesn't matter though since this function is only used to create+-- arrays with identical elements.+rep :: Monad m => Int -> m a -> m [a]+rep n m = go n [] where+  go 0 xs = pure xs+  go i xs = do+    x <- m+    go (i-1) (x:xs)
+ Control/Concurrent/Classy/STM/TBQueue.hs view
@@ -0,0 +1,146 @@+-- |+-- Module      : Control.Concurrent.Classy.STM.TBQueue+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum+-- capacity set when it is created.  If the queue already contains the+-- maximum number of elements, then 'writeTBQueue' blocks until an+-- element is removed from the queue.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-- __Deviations:__ @TBQueue@ as defined here does not have an @Eq@+-- instance, this is because the @MonadSTM@ @TVar@ type does not have+-- an @Eq@ constraint. Furthermore, the @newTBQueueIO@ function is not+-- provided.+module Control.Concurrent.Classy.STM.TBQueue+  ( -- * TBQueue+    TBQueue+  , newTBQueue+  , readTBQueue+  , tryReadTBQueue+  , peekTBQueue+  , tryPeekTBQueue+  , writeTBQueue+  , unGetTBQueue+  , isEmptyTBQueue+  , isFullTBQueue+  ) where++import Control.Monad.STM.Class++-- | 'TBQueue' is an abstract type representing a bounded FIFO+-- channel.+data TBQueue stm a+   = TBQueue (TVar stm Int)+             (TVar stm [a])+             (TVar stm Int)+             (TVar stm [a])++-- | Build and returns a new instance of 'TBQueue'+newTBQueue :: MonadSTM stm+  => Int   -- ^ maximum number of elements the queue can hold+  -> stm (TBQueue stm a)+newTBQueue size = do+  readT  <- newTVar []+  writeT <- newTVar []+  rsize <- newTVar 0+  wsize <- newTVar size+  pure (TBQueue rsize readT wsize writeT)++-- | Write a value to a 'TBQueue'; retries if the queue is full.+writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()+writeTBQueue (TBQueue rsize _ wsize writeT) a = do+  w <- readTVar wsize+  if w /= 0+  then writeTVar wsize (w - 1)+  else do+    r <- readTVar rsize+    if r /= 0+    then do+      writeTVar rsize 0+      writeTVar wsize (r - 1)+    else retry+  listend <- readTVar writeT+  writeTVar writeT (a:listend)++-- | Read the next value from the 'TBQueue'.+readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a+readTBQueue (TBQueue rsize readT _ writeT) = do+  xs <- readTVar readT+  r  <- readTVar rsize+  writeTVar rsize (r + 1)+  case xs of+    (x:xs') -> do+      writeTVar readT xs'+      pure x+    [] -> do+      ys <- readTVar writeT+      case ys of+        [] -> retry+        _  -> do+          let (z:zs) = reverse ys+          writeTVar writeT []+          writeTVar readT zs+          pure z++-- | A version of 'readTBQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)+tryReadTBQueue c = (Just <$> readTBQueue c) `orElse` pure Nothing++-- | Get the next value from the @TBQueue@ without removing it,+-- retrying if the channel is empty.+peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a+peekTBQueue c = do+  x <- readTBQueue c+  unGetTBQueue c x+  return x++-- | A version of 'peekTBQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)+tryPeekTBQueue c = do+  m <- tryReadTBQueue c+  case m of+    Nothing -> pure Nothing+    Just x  -> do+      unGetTBQueue c x+      pure m++-- | Put a data item back onto a channel, where it will be the next item read.+-- Retries if the queue is full.+unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()+unGetTBQueue (TBQueue rsize readT wsize _) a = do+  r <- readTVar rsize+  if r > 0+  then writeTVar rsize (r - 1)+  else do+    w <- readTVar wsize+    if w > 0+    then writeTVar wsize (w - 1)+    else retry+  xs <- readTVar readT+  writeTVar readT (a:xs)++-- | Returns 'True' if the supplied 'TBQueue' is empty.+isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool+isEmptyTBQueue (TBQueue _ readT _ writeT) = do+  xs <- readTVar readT+  case xs of+    (_:_) -> pure False+    [] -> null <$> readTVar writeT++-- | Returns 'True' if the supplied 'TBQueue' is full.+isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool+isFullTBQueue (TBQueue rsize _ wsize _) = do+  w <- readTVar wsize+  if w > 0+  then pure False+  else (>0) <$> readTVar rsize
+ Control/Concurrent/Classy/STM/TChan.hs view
@@ -0,0 +1,135 @@+-- |+-- Module      : Control.Concurrent.Classy.STM.TChan+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Transactional channels+--+-- __Deviations:__ @TChan@ as defined here does not have an @Eq@+-- instance, this is because the @MonadSTM@ @TVar@ type does not have+-- an @Eq@ constraint. Furthermore, the @newTChanIO@ and+-- @newBroadcastTChanIO@ functions are not provided.+module Control.Concurrent.Classy.STM.TChan+  ( -- * TChans+    TChan++  -- * Construction+  , newTChan+  , newBroadcastTChan+  , dupTChan+  , cloneTChan++  -- * Reading and writing+  , readTChan+  , tryReadTChan+  , peekTChan+  , tryPeekTChan+  , writeTChan+  , unGetTChan+  , isEmptyTChan+  ) where++import Control.Monad.STM.Class++-- | 'TChan' is an abstract type representing an unbounded FIFO+-- channel.+data TChan stm a = TChan (TVar stm (TVarList stm a))+                         (TVar stm (TVarList stm a))++type TVarList stm a = TVar stm (TList stm a)+data TList stm a = TNil | TCons a (TVarList stm a)++-- |Build and return a new instance of 'TChan'+newTChan :: MonadSTM stm => stm (TChan stm a)+newTChan = do+  hole   <- newTVar TNil+  readH  <- newTVar hole+  writeH <- newTVar hole+  pure (TChan readH writeH)++-- | Create a write-only 'TChan'.  More precisely, 'readTChan' will 'retry'+-- even after items have been written to the channel.  The only way to+-- read a broadcast channel is to duplicate it with 'dupTChan'.+newBroadcastTChan :: MonadSTM stm => stm (TChan stm a)+newBroadcastTChan = do+    hole   <- newTVar TNil+    readT  <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")+    writeT <- newTVar hole+    pure (TChan readT writeT)++-- | Write a value to a 'TChan'.+writeTChan :: MonadSTM stm => TChan stm a -> a -> stm ()+writeTChan (TChan _ writeT) a = do+  listend  <- readTVar writeT+  listend' <- newTVar TNil+  writeTVar listend (TCons a listend')+  writeTVar writeT listend'++-- | Read the next value from the 'TChan'.+readTChan :: MonadSTM stm => TChan stm a -> stm a+readTChan tchan = tryReadTChan tchan >>= maybe retry pure++-- | A version of 'readTChan' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a)+tryReadTChan (TChan readT _) = do+  listhead <- readTVar readT+  hd <- readTVar listhead+  case hd of+    TNil       -> pure Nothing+    TCons a tl -> do+      writeTVar readT tl+      pure (Just a)++-- | Get the next value from the 'TChan' without removing it,+-- retrying if the channel is empty.+peekTChan :: MonadSTM stm => TChan stm a -> stm a+peekTChan tchan = tryPeekTChan tchan >>= maybe retry pure++-- | A version of 'peekTChan' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a)+tryPeekTChan (TChan readT _) = do+  listhead <- readTVar readT+  hd <- readTVar listhead+  pure $ case hd of+    TNil      -> Nothing+    TCons a _ -> Just a++-- | Duplicate a 'TChan': the duplicate channel begins empty, but data written to+-- either channel from then on will be available from both.  Hence+-- this creates a kind of broadcast channel, where data written by+-- anyone is seen by everyone else.+dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a)+dupTChan (TChan _ writeT) = do+  hole   <- readTVar writeT+  readT' <- newTVar hole+  return (TChan readT' writeT)++-- | Put a data item back onto a channel, where it will be the next+-- item read.+unGetTChan :: MonadSTM stm => TChan stm a -> a -> stm ()+unGetTChan (TChan readT _) a = do+   listhead <- readTVar readT+   head' <- newTVar (TCons a listhead)+   writeTVar readT head'++-- | Returns 'True' if the supplied 'TChan' is empty.+isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool+isEmptyTChan (TChan readT _) = do+  listhead <- readTVar readT+  hd <- readTVar listhead+  pure $ case hd of+    TNil -> True+    TCons _ _ -> False++-- | Clone a 'TChan': similar to 'dupTChan', but the cloned channel starts with the+-- same content available as the original channel.+cloneTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a)+cloneTChan (TChan readT writeT) = do+  readpos <- readTVar readT+  readT' <- newTVar readpos+  pure (TChan readT' writeT)
+ Control/Concurrent/Classy/STM/TMVar.hs view
@@ -0,0 +1,118 @@+-- |+-- Module      : Control.Concurrent.Classy.STM.TMVar+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Transactional @MVar@s, for use with 'MonadSTM'.+--+-- __Deviations:__ @TMVar@ as defined here does not have an @Eq@+-- instance, this is because the @MonadSTM@ @TVar@ type does not have+-- an @Eq@ constraint. Furthermore, the @newTMVarIO@,+-- @newEmptyTMVarIO@, and @mkWeakTMVar@ functions are not provided.+module Control.Concurrent.Classy.STM.TMVar+  ( -- * @TMVar@s+    TMVar+  , newTMVar+  , newTMVarN+  , newEmptyTMVar+  , newEmptyTMVarN+  , takeTMVar+  , putTMVar+  , readTMVar+  , tryTakeTMVar+  , tryPutTMVar+  , tryReadTMVar+  , isEmptyTMVar+  , swapTMVar+  ) where++import Control.Monad (liftM, when, unless)+import Control.Monad.STM.Class+import Data.Maybe (isJust, isNothing)++-- | A @TMVar@ is like an @MVar@ or a @mVar@, but using transactional+-- memory. As transactions are atomic, this makes dealing with+-- multiple @TMVar@s easier than wrangling multiple @mVar@s.+newtype TMVar stm a = TMVar (TVar stm (Maybe a))++-- | Create a 'TMVar' containing the given value.+newTMVar :: MonadSTM stm => a -> stm (TMVar stm a)+newTMVar = newTMVarN ""++-- | Create a 'TMVar' containing the given value, with the given+-- name.+--+-- Name conflicts are handled as usual for 'TVar's. The name is+-- prefixed with \"ctmvar-\".+newTMVarN :: MonadSTM stm => String -> a -> stm (TMVar stm a)+newTMVarN n a = do+  let n' = if null n then "ctmvar" else "ctmvar-" ++ n+  ctvar <- newTVarN n' $ Just a+  return $ TMVar ctvar++-- | Create a new empty 'TMVar'.+newEmptyTMVar :: MonadSTM stm => stm (TMVar stm a)+newEmptyTMVar = newEmptyTMVarN ""++-- | Create a new empty 'TMVar' with the given name.+--+-- Name conflicts are handled as usual for 'TVar's. The name is+-- prefixed with \"ctmvar-\".+newEmptyTMVarN :: MonadSTM stm => String -> stm (TMVar stm a)+newEmptyTMVarN n = do+  let n' = if null n then "ctmvar" else "ctmvar-" ++ n+  ctvar <- newTVarN n' Nothing+  return $ TMVar ctvar++-- | Take the contents of a 'TMVar', or 'retry' if it is empty.+takeTMVar :: MonadSTM stm => TMVar stm a -> stm a+takeTMVar ctmvar = do+  taken <- tryTakeTMVar ctmvar+  maybe retry return taken++-- | Write to a 'TMVar', or 'retry' if it is full.+putTMVar :: MonadSTM stm => TMVar stm a -> a -> stm ()+putTMVar ctmvar a = do+  putted <- tryPutTMVar ctmvar a+  unless putted retry++-- | Read from a 'TMVar' without emptying, or 'retry' if it is empty.+readTMVar :: MonadSTM stm => TMVar stm a -> stm a+readTMVar ctmvar = do+  readed <- tryReadTMVar ctmvar+  maybe retry return readed++-- | Try to take the contents of a 'TMVar', returning 'Nothing' if it+-- is empty.+tryTakeTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a)+tryTakeTMVar (TMVar ctvar) = do+  val <- readTVar ctvar+  when (isJust val) $ writeTVar ctvar Nothing+  return val++-- | Try to write to a 'TMVar', returning 'False' if it is full.+tryPutTMVar :: MonadSTM stm => TMVar stm a -> a -> stm Bool+tryPutTMVar (TMVar ctvar) a = do+  val <- readTVar ctvar+  when (isNothing val) $ writeTVar ctvar (Just a)+  return $ isNothing val++-- | Try to read from a 'TMVar' without emptying, returning 'Nothing'+-- if it is empty.+tryReadTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a)+tryReadTMVar (TMVar ctvar) = readTVar ctvar++-- | Check if a 'TMVar' is empty or not.+isEmptyTMVar :: MonadSTM stm => TMVar stm a -> stm Bool+isEmptyTMVar ctmvar = isNothing `liftM` tryReadTMVar ctmvar++-- | Swap the contents of a 'TMVar' returning the old contents, or+-- 'retry' if it is empty.+swapTMVar :: MonadSTM stm => TMVar stm a -> a -> stm a+swapTMVar ctmvar a = do+  val <- takeTMVar ctmvar+  putTMVar ctmvar a+  return val
+ Control/Concurrent/Classy/STM/TQueue.hs view
@@ -0,0 +1,113 @@+-- |+-- Module      : Control.Concurrent.Classy.STM.TQueue+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- A 'TQueue' is like a 'TChan', with two important differences:+--+--  * it has faster throughput than both 'TChan' and 'Chan' (although+--    the costs are amortised, so the cost of individual operations+--    can vary a lot).+--+--  * it does /not/ provide equivalents of the 'dupTChan' and+--    'cloneTChan' operations.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-- __Deviations:__ @TQueue@ as defined here does not have an @Eq@+-- instance, this is because the @MonadSTM@ @TVar@ type does not have+-- an @Eq@ constraint. Furthermore, the @newTQueueIO@ function is not+-- provided.+module Control.Concurrent.Classy.STM.TQueue+  ( -- * TQueue+    TQueue+  , newTQueue+  , readTQueue+  , tryReadTQueue+  , peekTQueue+  , tryPeekTQueue+  , writeTQueue+  , unGetTQueue+  , isEmptyTQueue+  ) where++import Control.Monad.STM.Class++-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.+data TQueue stm a = TQueue (TVar stm [a])+                           (TVar stm [a])++-- | Build and returns a new instance of 'TQueue'+newTQueue :: MonadSTM stm => stm (TQueue stm a)+newTQueue = do+  readT  <- newTVar []+  writeT <- newTVar []+  pure (TQueue readT writeT)++-- | Write a value to a 'TQueue'.+writeTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()+writeTQueue (TQueue _ writeT) a = do+  listend <- readTVar writeT+  writeTVar writeT (a:listend)++-- | Read the next value from the 'TQueue'.+readTQueue :: MonadSTM stm => TQueue stm a -> stm a+readTQueue (TQueue readT writeT) = do+  xs <- readTVar readT+  case xs of+    (x:xs') -> do+      writeTVar readT xs'+      pure x+    [] -> do+      ys <- readTVar writeT+      case ys of+        [] -> retry+        _  -> case reverse ys of+               [] -> error "readTQueue"+               (z:zs) -> do+                 writeTVar writeT []+                 writeTVar readT zs+                 pure z++-- | A version of 'readTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)+tryReadTQueue c = (Just <$> readTQueue c) `orElse` pure Nothing++-- | Get the next value from the @TQueue@ without removing it,+-- retrying if the channel is empty.+peekTQueue :: MonadSTM stm => TQueue stm a -> stm a+peekTQueue c = do+  x <- readTQueue c+  unGetTQueue c x+  pure x++-- | A version of 'peekTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)+tryPeekTQueue c = do+  m <- tryReadTQueue c+  case m of+    Nothing -> pure Nothing+    Just x  -> do+      unGetTQueue c x+      pure m++-- |Put a data item back onto a channel, where it will be the next item read.+unGetTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()+unGetTQueue (TQueue readT _) a = do+  xs <- readTVar readT+  writeTVar readT (a:xs)++-- |Returns 'True' if the supplied 'TQueue' is empty.+isEmptyTQueue :: MonadSTM stm => TQueue stm a -> stm Bool+isEmptyTQueue (TQueue readT writeT) = do+  xs <- readTVar readT+  case xs of+    (_:_) -> pure False+    [] -> null <$> readTVar writeT
+ Control/Concurrent/Classy/STM/TVar.hs view
@@ -0,0 +1,62 @@+-- |+-- Module      : Control.Concurrent.Classy.STM.TVar+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- Transactional variables, for use with 'MonadSTM'.+--+-- __Deviations:__ There is no @Eq@ instance for @MonadSTM@ the @TVar@+-- type. Furthermore, the @newTVarIO@ and @mkWeakTVar@ functions are+-- not provided.+module Control.Concurrent.Classy.STM.TVar+  ( -- * @TVar@s+    TVar+  , newTVar+  , newTVarN+  , readTVar+  , readTVarConc+  , writeTVar+  , modifyTVar+  , modifyTVar'+  , swapTVar+  , registerDelay+  ) where++import Control.Monad.STM.Class+import Control.Monad.Conc.Class+import Data.Functor (void)++-- * @TVar@s++-- | Mutate the contents of a 'TVar'. This is non-strict.+modifyTVar :: MonadSTM stm => TVar stm a -> (a -> a) -> stm ()+modifyTVar ctvar f = do+  a <- readTVar ctvar+  writeTVar ctvar $ f a++-- | Mutate the contents of a 'TVar' strictly.+modifyTVar' :: MonadSTM stm => TVar stm a -> (a -> a) -> stm ()+modifyTVar' ctvar f = do+  a <- readTVar ctvar+  writeTVar ctvar $! f a++-- | Swap the contents of a 'TVar', returning the old value.+swapTVar :: MonadSTM stm => TVar stm a -> a -> stm a+swapTVar ctvar a = do+  old <- readTVar ctvar+  writeTVar ctvar a+  return old++-- | Set the value of returned 'TVar' to @True@ after a given number+-- of microseconds. The caveats associated with 'threadDelay' also+-- apply.+registerDelay :: MonadConc m => Int -> m (TVar (STM m) Bool)+registerDelay delay = do+  var <- atomically (newTVar False)+  void . fork $ do+    threadDelay delay+    atomically (writeTVar var True)+  pure var
+ Control/Monad/Conc/Class.hs view
@@ -0,0 +1,629 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Control.Monad.Conc.Class+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : experimental+-- Portability : CPP, FlexibleContexts, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies+--+-- This module captures in a typeclass the interface of concurrency+-- monads.+--+-- __Deviations:__ An instance of @MonadConc@ is not required to be+-- an instance of @MonadFix@, unlike @IO@. The @CRef@, @MVar@, and+-- @Ticket@ types are not required to be instances of @Show@ or @Eq@,+-- unlike their normal counterparts. The @threadCapability@,+-- @threadWaitRead@, @threadWaitWrite@, @threadWaitReadSTM@,+-- @threadWaitWriteSTM@, and @mkWeakThreadId@ functions are not+-- provided. The @threadDelay@ function is not required to delay the+-- thread, merely to yield it. Bound threads are not supported. The+-- @BlockedIndefinitelyOnMVar@ (and similar) exceptions are /not/+-- thrown during testing, so do not rely on them at all.+module Control.Monad.Conc.Class+  ( MonadConc(..)++  -- * Threads+  , spawn+  , forkFinally+  , killThread++  -- ** Named Threads+  , forkN+  , forkOnN++  -- ** Bound Threads++  -- | @MonadConc@ does not support bound threads, if you need that+  -- sort of thing you will have to use regular @IO@.++  , rtsSupportsBoundThreads+  , isCurrentThreadBound++  -- * Exceptions+  , throw+  , catch+  , mask+  , uninterruptibleMask++  -- * Mutable State+  , newMVar+  , newMVarN+  , cas+  , peekTicket++  -- * Utilities for instance writers+  , liftedF+  , liftedFork+  ) where++-- for the class and utilities+import Control.Exception (Exception, AsyncException(ThreadKilled), SomeException)+import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)+import qualified Control.Monad.Catch as Ca+import Control.Monad.STM.Class (MonadSTM, TVar, readTVar)+import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith)+import Data.Proxy (Proxy(..))+import Data.Typeable (Typeable)++-- for the 'IO' instance+import qualified Control.Concurrent as IO+import qualified Control.Concurrent.STM.TVar as IO+import qualified Control.Monad.STM as IO+import qualified Data.Atomics as IO+import qualified Data.IORef as IO++-- for the transformer instances+import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Identity (IdentityT)+import qualified Control.Monad.RWS.Lazy as RL+import qualified Control.Monad.RWS.Strict as RS+import qualified Control.Monad.State.Lazy as SL+import qualified Control.Monad.State.Strict as SS+import qualified Control.Monad.Writer.Lazy as WL+import qualified Control.Monad.Writer.Strict as WS++{-# ANN module ("HLint: ignore Use const" :: String) #-}++-- | @MonadConc@ is an abstraction over GHC's typical concurrency+-- abstraction. It captures the interface of concurrency monads in+-- terms of how they can operate on shared state and in the presence+-- of exceptions.+--+-- Every @MonadConc@ has an associated 'MonadSTM', transactions of+-- which can be run atomically.+class ( Applicative m, Monad m+      , MonadCatch m, MonadThrow m, MonadMask m+      , MonadSTM (STM m)+      , Ord (ThreadId m), Show (ThreadId m)) => MonadConc m  where++  {-# MINIMAL+        (forkWithUnmask | forkWithUnmaskN)+      , (forkOnWithUnmask | forkOnWithUnmaskN)+      , getNumCapabilities+      , setNumCapabilities+      , myThreadId+      , yield+      , (newEmptyMVar | newEmptyMVarN)+      , putMVar+      , tryPutMVar+      , readMVar+      , takeMVar+      , tryTakeMVar+      , (newCRef | newCRefN)+      , atomicModifyCRef+      , writeCRef+      , readForCAS+      , peekTicket'+      , casCRef+      , modifyCRefCAS+      , atomically+      , throwTo+    #-}++  -- | The associated 'MonadSTM' for this class.+  type STM m :: * -> *++  -- | The mutable reference type, like 'MVar's. This may contain one+  -- value at a time, attempting to read or take from an \"empty\"+  -- @MVar@ will block until it is full, and attempting to put to a+  -- \"full\" @MVar@ will block until it is empty.+  type MVar m :: * -> *++  -- | The mutable non-blocking reference type. These may suffer from+  -- relaxed memory effects if functions outside the set @newCRef@,+  -- @readCRef@, @atomicModifyCRef@, and @atomicWriteCRef@ are used.+  type CRef m :: * -> *++  -- | When performing compare-and-swap operations on @CRef@s, a+  -- @Ticket@ is a proof that a thread observed a specific previous+  -- value.+  type Ticket m :: * -> *++  -- | An abstract handle to a thread.+  type ThreadId m :: *++  -- | Fork a computation to happen concurrently. Communication may+  -- happen over @MVar@s.+  --+  -- > fork ma = forkWithUnmask (\_ -> ma)+  fork :: m () -> m (ThreadId m)+  fork ma = forkWithUnmask (\_ -> ma)++  -- | Like 'fork', but the child thread is passed a function that can+  -- be used to unmask asynchronous exceptions. This function should+  -- not be used within a 'mask' or 'uninterruptibleMask'.+  --+  -- > forkWithUnmask = forkWithUnmaskN ""+  forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)+  forkWithUnmask = forkWithUnmaskN ""++  -- | Like 'forkWithUnmask', but the thread is given a name which may+  -- be used to present more useful debugging information.+  --+  -- If an empty name is given, the @ThreadId@ is used. If names+  -- conflict, successive threads with the same name are given a+  -- numeric suffix, counting up from 1.+  --+  -- > forkWithUnmaskN _ = forkWithUnmask+  forkWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)+  forkWithUnmaskN _ = forkWithUnmask++  -- | Fork a computation to happen on a specific processor. The+  -- specified int is the /capability number/, typically capabilities+  -- correspond to physical processors or cores but this is+  -- implementation dependent. The int is interpreted modulo to the+  -- total number of capabilities as returned by 'getNumCapabilities'.+  --+  -- > forkOn c ma = forkOnWithUnmask c (\_ -> ma)+  forkOn :: Int -> m () -> m (ThreadId m)+  forkOn c ma = forkOnWithUnmask c (\_ -> ma)++  -- | Like 'forkWithUnmask', but the child thread is pinned to the+  -- given CPU, as with 'forkOn'.+  --+  -- > forkOnWithUnmask = forkOnWithUnmaskN ""+  forkOnWithUnmask :: Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)+  forkOnWithUnmask = forkOnWithUnmaskN ""++  -- | Like 'forkWithUnmaskN', but the child thread is pinned to the+  -- given CPU, as with 'forkOn'.+  --+  -- > forkOnWithUnmaskN _ = forkOnWithUnmask+  forkOnWithUnmaskN :: String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)+  forkOnWithUnmaskN _ = forkOnWithUnmask++  -- | Get the number of Haskell threads that can run simultaneously.+  getNumCapabilities :: m Int++  -- | Set the number of Haskell threads that can run simultaneously.+  setNumCapabilities :: Int -> m ()++  -- | Get the @ThreadId@ of the current thread.+  myThreadId :: m (ThreadId m)++  -- | Allows a context-switch to any other currently runnable thread+  -- (if any).+  yield :: m ()++  -- | Yields the current thread, and optionally suspends the current+  -- thread for a given number of microseconds.+  --+  -- If suspended, 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.+  --+  -- > threadDelay _ = yield+  threadDelay :: Int -> m ()+  threadDelay _ = yield++  -- | Create a new empty @MVar@.+  --+  -- > newEmptyMVar = newEmptyMVarN ""+  newEmptyMVar :: m (MVar m a)+  newEmptyMVar = newEmptyMVarN ""++  -- | Create a new empty @MVar@, but it is given a name which may be+  -- used to present more useful debugging information.+  --+  -- If an empty name is given, a counter starting from 0 is used. If+  -- names conflict, successive @MVar@s with the same name are given a+  -- numeric suffix, counting up from 1.+  --+  -- > newEmptyMVarN _ = newEmptyMVar+  newEmptyMVarN :: String -> m (MVar m a)+  newEmptyMVarN _ = newEmptyMVar++  -- | Put a value into a @MVar@. If there is already a value there,+  -- this will block until that value has been taken, at which point+  -- the value will be stored.+  putMVar :: MVar m a -> a -> m ()++  -- | Attempt to put a value in a @MVar@ non-blockingly, returning+  -- 'True' (and filling the @MVar@) if there was nothing there,+  -- otherwise returning 'False'.+  tryPutMVar :: MVar m a -> a -> m Bool++  -- | Block until a value is present in the @MVar@, and then return+  -- it. As with 'readMVar', this does not \"remove\" the value,+  -- multiple reads are possible.+  readMVar :: MVar m a -> m a++  -- | Take a value from a @MVar@. This \"empties\" the @MVar@,+  -- allowing a new value to be put in. This will block if there is no+  -- value in the @MVar@ already, until one has been put.+  takeMVar :: MVar m a -> m a++  -- | Attempt to take a value from a @MVar@ non-blockingly, returning+  -- a 'Just' (and emptying the @MVar@) if there was something there,+  -- otherwise returning 'Nothing'.+  tryTakeMVar :: MVar m a -> m (Maybe a)++  -- | Create a new reference.+  --+  -- > newCRef = newCRefN ""+  newCRef :: a -> m (CRef m a)+  newCRef = newCRefN ""++  -- | Create a new reference, but it is given a name which may be+  -- used to present more useful debugging information.+  --+  -- If an empty name is given, a counter starting from 0 is used. If+  -- names conflict, successive @CRef@s with the same name are given a+  -- numeric suffix, counting up from 1.+  --+  -- > newCRefN _ = newCRef+  newCRefN :: String -> a -> m (CRef m a)+  newCRefN _ = newCRef++  -- | Read the current value stored in a reference.+  --+  -- > readCRef cref = readForCAS cref >>= peekTicket+  readCRef :: CRef m a -> m a+  readCRef cref = readForCAS cref >>= peekTicket++  -- | Atomically modify the value stored in a reference. This imposes+  -- a full memory barrier.+  atomicModifyCRef :: CRef m a -> (a -> (a, b)) -> m b++  -- | Write a new value into an @CRef@, without imposing a memory+  -- barrier. This means that relaxed memory effects can be observed.+  writeCRef :: CRef m a -> a -> m ()++  -- | Replace the value stored in a reference, with the+  -- barrier-to-reordering property that 'atomicModifyCRef' has.+  --+  -- > atomicWriteCRef r a = atomicModifyCRef r $ const (a, ())+  atomicWriteCRef :: CRef m a -> a -> m ()+  atomicWriteCRef r a = atomicModifyCRef r $ const (a, ())++  -- | Read the current value stored in a reference, returning a+  -- @Ticket@, for use in future compare-and-swap operations.+  readForCAS :: CRef m a -> m (Ticket m a)++  -- | Extract the actual Haskell value from a @Ticket@.+  --+  -- The @proxy m@ is to determine the @m@ in the @Ticket@ type.+  peekTicket' :: proxy m -> Ticket m a -> a++  -- | Perform a machine-level compare-and-swap (CAS) operation on a+  -- @CRef@. Returns an indication of success and a @Ticket@ for the+  -- most current value in the @CRef@.+  --+  -- This is strict in the \"new\" value argument.+  casCRef :: CRef m a -> Ticket m a -> a -> m (Bool, Ticket m a)++  -- | A replacement for 'atomicModifyCRef' using a compare-and-swap.+  --+  -- This is strict in the \"new\" value argument.+  modifyCRefCAS :: CRef m a -> (a -> (a, b)) -> m b++  -- | A variant of 'modifyCRefCAS' which doesn't return a result.+  --+  -- > modifyCRefCAS_ cref f = modifyCRefCAS cref (\a -> (f a, ()))+  modifyCRefCAS_ :: CRef m a -> (a -> a) -> m ()+  modifyCRefCAS_ cref f = modifyCRefCAS cref (\a -> (f a, ()))++  -- | Perform an STM transaction atomically.+  atomically :: STM m a -> m a++  -- | Read the current value stored in a @TVar@. This may be+  -- implemented differently for speed.+  --+  -- > readTVarConc = atomically . readTVar+  readTVarConc :: TVar (STM m) a -> m a+  readTVarConc = atomically . readTVar++  -- | Throw an exception to the target thread. This blocks until the+  -- exception is delivered, and it is just as if the target thread+  -- had raised it with 'throw'. This can interrupt a blocked action.+  throwTo :: Exception e => ThreadId m -> e -> m ()++  -- | Does nothing.+  --+  -- During testing, records a message which shows up in the trace.+  --+  -- > _concMessage _ = pure ()+  _concMessage :: Typeable a => a -> m ()+  _concMessage _ = pure ()++-------------------------------------------------------------------------------+-- Utilities++-- Threads++-- | Create a concurrent computation for the provided action, and+-- return a @MVar@ which can be used to query the result.+spawn :: MonadConc m => m a -> m (MVar m a)+spawn ma = do+  cvar <- newEmptyMVar+  _ <- fork $ ma >>= putMVar cvar+  pure cvar++-- | Fork a thread and call the supplied function when the thread is+-- about to terminate, with an exception or a returned value. The+-- function is called with asynchronous exceptions masked.+--+-- This function is useful for informing the parent when a child+-- terminates, for example.+forkFinally :: MonadConc m => m a -> (Either SomeException a -> m ()) -> m (ThreadId m)+forkFinally action and_then =+  mask $ \restore ->+    fork $ Ca.try (restore action) >>= and_then++-- | Raise the 'ThreadKilled' exception in the target thread. Note+-- that if the thread is prepared to catch this exception, it won't+-- actually kill it.+killThread :: MonadConc m => ThreadId m -> m ()+killThread tid = throwTo tid ThreadKilled++-- | Like 'fork', but the thread is given a name which may be used to+-- present more useful debugging information.+--+-- If no name is given, the @ThreadId@ is used. If names conflict,+-- successive threads with the same name are given a numeric suffix,+-- counting up from 1.+forkN :: MonadConc m => String -> m () -> m (ThreadId m)+forkN name ma = forkWithUnmaskN name (\_ -> ma)++-- | Like 'forkOn', but the thread is given a name which may be used+-- to present more useful debugging information.+--+-- If no name is given, the @ThreadId@ is used. If names conflict,+-- successive threads with the same name are given a numeric suffix,+-- counting up from 1.+forkOnN :: MonadConc m => String -> Int -> m () -> m (ThreadId m)+forkOnN name i ma = forkOnWithUnmaskN name i (\_ -> ma)++-- Bound Threads++-- | Provided for compatibility, always returns 'False'.+rtsSupportsBoundThreads :: Bool+rtsSupportsBoundThreads = False++-- | Provided for compatibility, always returns 'False'.+isCurrentThreadBound :: MonadConc m => m Bool+isCurrentThreadBound = pure False++-- Exceptions++-- | Throw an exception. This will \"bubble up\" looking for an+-- exception handler capable of dealing with it and, if one is not+-- found, the thread is killed.+throw :: (MonadConc m, Exception e) => e -> m a+throw = Ca.throwM++-- | Catch an exception. This is only required to be able to catch+-- exceptions raised by 'throw', unlike the more general+-- Control.Exception.catch function. If you need to be able to catch+-- /all/ errors, you will have to use 'IO'.+catch :: (MonadConc m, Exception e) => m a -> (e -> m a) -> m a+catch = Ca.catch++-- | Executes a computation with asynchronous exceptions+-- /masked/. That is, any thread which attempts to raise an exception+-- in the current thread with 'throwTo' will be blocked until+-- asynchronous exceptions are unmasked again.+--+-- The argument passed to mask is a function that takes as its+-- argument another function, which can be used to restore the+-- prevailing masking state within the context of the masked+-- computation. This function should not be used within an+-- 'uninterruptibleMask'.+mask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b+mask = Ca.mask++-- | Like 'mask', but the masked computation is not+-- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a+-- thread executing in 'uninterruptibleMask' blocks for any reason,+-- then the thread (and possibly the program, if this is the main+-- thread) will be unresponsive and unkillable. This function should+-- only be necessary if you need to mask exceptions around an+-- interruptible operation, and you can guarantee that the+-- interruptible operation will only block for a short period of+-- time. The supplied unmasking function should not be used within a+-- 'mask'.+uninterruptibleMask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b+uninterruptibleMask = Ca.uninterruptibleMask++-- Mutable Variables++-- | Create a new @MVar@ containing a value.+newMVar :: MonadConc m => a -> m (MVar m a)+newMVar a = do+  cvar <- newEmptyMVar+  putMVar cvar a+  pure cvar++-- | Create a new @MVar@ containing a value, but it is given a name+-- which may be used to present more useful debugging information.+--+-- If no name is given, a counter starting from 0 is used. If names+-- conflict, successive @MVar@s with the same name are given a numeric+-- suffix, counting up from 1.+newMVarN :: MonadConc m => String -> a -> m (MVar m a)+newMVarN n a = do+  cvar <- newEmptyMVarN n+  putMVar cvar a+  pure cvar++-- | Extract the actual Haskell value from a @Ticket@.+--+-- This doesn't do do any monadic computation, the @m@ appears in the+-- result type to determine the @m@ in the @Ticket@ type.+peekTicket :: forall m a. MonadConc m => Ticket m a -> m a+peekTicket t = pure $ peekTicket' (Proxy :: Proxy m) (t :: Ticket m a)++-- | Compare-and-swap a value in a @CRef@, returning an indication of+-- success and the new value.+cas :: MonadConc m => CRef m a -> a -> m (Bool, a)+cas cref a = do+  tick         <- readForCAS cref+  (suc, tick') <- casCRef cref tick a+  a'           <- peekTicket tick'++  pure (suc, a')++-------------------------------------------------------------------------------+-- Concrete instances++instance MonadConc IO where+  type STM      IO = IO.STM+  type MVar     IO = IO.MVar+  type CRef     IO = IO.IORef+  type Ticket   IO = IO.Ticket+  type ThreadId IO = IO.ThreadId++  fork   = IO.forkIO+  forkOn = IO.forkOn++  forkWithUnmask   = IO.forkIOWithUnmask+  forkOnWithUnmask = IO.forkOnWithUnmask++  getNumCapabilities = IO.getNumCapabilities+  setNumCapabilities = IO.setNumCapabilities+  readMVar           = IO.readMVar+  myThreadId         = IO.myThreadId+  yield              = IO.yield+  threadDelay        = IO.threadDelay+  throwTo            = IO.throwTo+  newEmptyMVar       = IO.newEmptyMVar+  putMVar            = IO.putMVar+  tryPutMVar         = IO.tryPutMVar+  takeMVar           = IO.takeMVar+  tryTakeMVar        = IO.tryTakeMVar+  newCRef            = IO.newIORef+  readCRef           = IO.readIORef+  atomicModifyCRef   = IO.atomicModifyIORef+  writeCRef          = IO.writeIORef+  atomicWriteCRef    = IO.atomicWriteIORef+  readForCAS         = IO.readForCAS+  peekTicket' _      = IO.peekTicket+  casCRef            = IO.casIORef+  modifyCRefCAS      = IO.atomicModifyIORefCAS+  atomically         = IO.atomically+  readTVarConc       = IO.readTVarIO++-------------------------------------------------------------------------------+-- Transformer instances++#define INSTANCE(T,C,F)                                          \+instance C => MonadConc (T m) where                             { \+  type STM      (T m) = STM m                                  ; \+  type MVar     (T m) = MVar m                                 ; \+  type CRef     (T m) = CRef m                                 ; \+  type Ticket   (T m) = Ticket m                               ; \+  type ThreadId (T m) = ThreadId m                             ; \+                                                                 \+  fork   = liftedF F fork                                      ; \+  forkOn = liftedF F . forkOn                                  ; \+                                                                 \+  forkWithUnmask        = liftedFork F forkWithUnmask          ; \+  forkWithUnmaskN   n   = liftedFork F (forkWithUnmaskN   n  ) ; \+  forkOnWithUnmask    i = liftedFork F (forkOnWithUnmask    i) ; \+  forkOnWithUnmaskN n i = liftedFork F (forkOnWithUnmaskN n i) ; \+                                                                 \+  getNumCapabilities = lift getNumCapabilities                 ; \+  setNumCapabilities = lift . setNumCapabilities               ; \+  myThreadId         = lift myThreadId                         ; \+  yield              = lift yield                              ; \+  threadDelay        = lift . threadDelay                      ; \+  throwTo t          = lift . throwTo t                        ; \+  newEmptyMVar       = lift newEmptyMVar                       ; \+  newEmptyMVarN      = lift . newEmptyMVarN                    ; \+  readMVar           = lift . readMVar                         ; \+  putMVar v          = lift . putMVar v                        ; \+  tryPutMVar v       = lift . tryPutMVar v                     ; \+  takeMVar           = lift . takeMVar                         ; \+  tryTakeMVar        = lift . tryTakeMVar                      ; \+  newCRef            = lift . newCRef                          ; \+  newCRefN n         = lift . newCRefN n                       ; \+  readCRef           = lift . readCRef                         ; \+  atomicModifyCRef r = lift . atomicModifyCRef r               ; \+  writeCRef r        = lift . writeCRef r                      ; \+  atomicWriteCRef r  = lift . atomicWriteCRef r                ; \+  readForCAS         = lift . readForCAS                       ; \+  peekTicket' _      = peekTicket' (Proxy :: Proxy m)          ; \+  casCRef r t        = lift . casCRef r t                      ; \+  modifyCRefCAS r    = lift . modifyCRefCAS r                  ; \+  atomically         = lift . atomically                       ; \+  readTVarConc       = lift . readTVarConc                     ; \+                                                                 \+  _concMessage    = lift . _concMessage                        }++-- | New threads inherit the reader state of their parent, but do not+-- communicate results back.+INSTANCE(ReaderT r, MonadConc m, id)++INSTANCE(IdentityT, MonadConc m, id)++-- | New threads inherit the writer state of their parent, but do not+-- communicate results back.+INSTANCE(WL.WriterT w, (MonadConc m, Monoid w), fst)+-- | New threads inherit the writer state of their parent, but do not+-- communicate results back.+INSTANCE(WS.WriterT w, (MonadConc m, Monoid w), fst)++-- | New threads inherit the state of their parent, but do not+-- communicate results back.+INSTANCE(SL.StateT s, MonadConc m, fst)+-- | New threads inherit the state of their parent, but do not+-- communicate results back.+INSTANCE(SS.StateT s, MonadConc m, fst)++-- | New threads inherit the states of their parent, but do not+-- communicate results back.+INSTANCE(RL.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a))+-- | New threads inherit the states of their parent, but do not+-- communicate results back.+INSTANCE(RS.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a))++#undef INSTANCE++-------------------------------------------------------------------------------++-- | Given a function to remove the transformer-specific state, lift+-- a function invocation.+liftedF :: (MonadTransControl t, MonadConc m)+  => (forall x. StT t x -> x)+  -> (m a -> m b)+  -> t m a+  -> t m b+liftedF unst f ma = liftWith $ \run -> f (unst <$> run ma)++-- | Given a function to remove the transformer-specific state, lift+-- a @fork(on)WithUnmask@ invocation.+liftedFork :: (MonadTransControl t, MonadConc m)+  => (forall x. StT t x -> x)+  -> (((forall x. m x -> m x) -> m a) -> m b)+  -> ((forall x. t m x -> t m x) -> t m a)+  -> t m b+liftedFork unst f ma = liftWith $ \run ->+  f (\unmask -> unst <$> run (ma $ liftedF unst unmask))
+ Control/Monad/STM/Class.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Control.Monad.STM.Class+-- Copyright   : (c) 2016 Michael Walker+-- License     : MIT+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>+-- Stability   : experimental+-- Portability : CPP, RankNTypes, TemplateHaskell, TypeFamilies+--+-- This module provides an abstraction over 'STM', which can be used+-- with 'MonadConc'.+--+-- This module only defines the 'STM' class; you probably want to+-- import "Control.Concurrent.Classy.STM" (which exports+-- "Control.Monad.STM.Class").+--+-- __Deviations:__ An instance of @MonadSTM@ is not required to be an+-- @Alternative@, @MonadPlus@, and @MonadFix@, unlike @STM@. The+-- @always@ and @alwaysSucceeds@ functions are not provided; if you+-- need these file an issue and I'll look into it.+module Control.Monad.STM.Class+  ( MonadSTM(..)+  , check+  , throwSTM+  , catchSTM++  -- * Utilities for instance writers+  , liftedOrElse+  ) where++import Control.Exception (Exception)+import Control.Monad (unless)+import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith)+import Control.Monad.Trans.Identity (IdentityT)++import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.Catch as Ca+import qualified Control.Monad.RWS.Lazy as RL+import qualified Control.Monad.RWS.Strict as RS+import qualified Control.Monad.State.Lazy as SL+import qualified Control.Monad.State.Strict as SS+import qualified Control.Monad.Writer.Lazy as WL+import qualified Control.Monad.Writer.Strict as WS++-- | @MonadSTM@ is an abstraction over 'STM'.+--+-- This class does not provide any way to run transactions, rather+-- each 'MonadConc' has an associated @MonadSTM@ from which it can+-- atomically run a transaction.+class Ca.MonadCatch stm => MonadSTM stm where+  {-# MINIMAL+        retry+      , orElse+      , (newTVar | newTVarN)+      , readTVar+      , writeTVar+    #-}++  -- | The mutable reference type. These behave like 'TVar's, in that+  -- they always contain a value and updates are non-blocking and+  -- synchronised.+  type TVar stm :: * -> *++  -- | Retry execution of this transaction because it has seen values+  -- in @TVar@s that it shouldn't have. This will result in the+  -- thread running the transaction being blocked until any @TVar@s+  -- referenced in it have been mutated.+  retry :: stm a++  -- | Run the first transaction and, if it @retry@s, run the second+  -- instead. If the monad is an instance of+  -- 'Alternative'/'MonadPlus', 'orElse' should be the '(<|>)'/'mplus'+  -- function.+  orElse :: stm a -> stm a -> stm a++  -- | Create a new @TVar@ containing the given value.+  --+  -- > newTVar = newTVarN ""+  newTVar :: a -> stm (TVar stm a)+  newTVar = newTVarN ""++  -- | Create a new @TVar@ containing the given value, but it is+  -- given a name which may be used to present more useful debugging+  -- information.+  --+  -- If an empty name is given, a counter starting from 0 is used. If+  -- names conflict, successive @TVar@s with the same name are given+  -- a numeric suffix, counting up from 1.+  --+  -- > newTVarN _ = newTVar+  newTVarN :: String -> a -> stm (TVar stm a)+  newTVarN _ = newTVar++  -- | Return the current value stored in a @TVar@.+  readTVar :: TVar stm a -> stm a++  -- | Write the supplied value into the @TVar@.+  writeTVar :: TVar stm a -> a -> stm ()++-- | Check whether a condition is true and, if not, call @retry@.+check :: MonadSTM stm => Bool -> stm ()+check b = unless b retry++-- | Throw an exception. This aborts the transaction and propagates+-- the exception.+throwSTM :: (MonadSTM stm, Exception e) => e -> stm a+throwSTM = Ca.throwM++-- | Handling exceptions from 'throwSTM'.+catchSTM :: (MonadSTM stm, Exception e) => stm a -> (e -> stm a) -> stm a+catchSTM = Ca.catch++instance MonadSTM STM.STM where+  type TVar STM.STM = STM.TVar++  retry     = STM.retry+  orElse    = STM.orElse+  newTVar   = STM.newTVar+  readTVar  = STM.readTVar+  writeTVar = STM.writeTVar++-------------------------------------------------------------------------------+-- Transformer instances++#define INSTANCE(T,C,F)                                  \+instance C => MonadSTM (T stm) where { \+  type TVar (T stm) = TVar stm      ; \+                                      \+  retry       = lift retry          ; \+  orElse      = liftedOrElse F      ; \+  newTVar     = lift . newTVar      ; \+  newTVarN n  = lift . newTVarN n   ; \+  readTVar    = lift . readTVar     ; \+  writeTVar v = lift . writeTVar v  }++INSTANCE(ReaderT r, MonadSTM stm, id)++INSTANCE(IdentityT, MonadSTM stm, id)++INSTANCE(WL.WriterT w, (MonadSTM stm, Monoid w), fst)+INSTANCE(WS.WriterT w, (MonadSTM stm, Monoid w), fst)++INSTANCE(SL.StateT s, MonadSTM stm, fst)+INSTANCE(SS.StateT s, MonadSTM stm, fst)++INSTANCE(RL.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a))+INSTANCE(RS.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a))++#undef INSTANCE++-------------------------------------------------------------------------------++-- | Given a function to remove the transformer-specific state, lift+-- an @orElse@ invocation.+liftedOrElse :: (MonadTransControl t, MonadSTM stm)+  => (forall x. StT t x -> x)+  -> t stm a -> t stm a -> t stm a+liftedOrElse unst ma mb = liftWith $ \run ->+  let ma' = unst <$> run ma+      mb' = unst <$> run mb+  in ma' `orElse` mb'
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015, Michael Walker <mike@barrucadu.co.uk>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ concurrency.cabal view
@@ -0,0 +1,113 @@+-- Initial monad-conc.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                concurrency+version:             1.0.0.0+synopsis:            Typeclasses, functions, and data types for concurrency and STM.++description:+  A typeclass abstraction over much of Control.Concurrent (and some+  extras!). If you're looking for a general introduction to Haskell+  concurrency, you should check out the excellent Parallel and+  Concurrent Programming in Haskell, by Simon Marlow. If you are+  already familiar with concurrent Haskell, just change all the+  imports from Control.Concurrent.* to Control.Concurrent.Classy.* and+  fix the type errors.+  .+  A brief list of supported functionality:+  .+  * Threads: the @forkIO*@ and @forkOn*@ functions, although bound+    threads are not supported.+  .+  * Getting and setting capablities.+  .+  * Yielding and delaying.+  .+  * Mutable state: STM, @MVar@, and @IORef@.+  .+  * Atomic compare-and-swap for @IORef@.+  .+  * Exceptions.+  .+  * All of the data structures in Control.Concurrent.* and+    Control.Concurrent.STM.* have typeclass-abstracted equivalents.+  .+  This is quite a rich set of functionality, although it is not+  complete. If there is something else you need, file an issue!+  .+  This used to be part of dejafu, but with the dejafu-0.4.0.0 release,+  it was split out into its own package.+  .+  == Why and not something else?+  .+  * Why not base: like lifted-base, concurrency uses typeclasses to+    make function types more generic. This automatically eliminates+    calls to `lift` in many cases, resulting in clearer and simpler+    code.+  .+  * Why not lifted-base: fundamentally, lifted-base is still using+    actual threads and actual mutable variables. When using a+    concurrency-specific typeclass, this isn't necessarily the case.+    The dejafu library provides non-IO-based implementations to allow+    testing concurrent programs.+  .+  * Why not IOSpec: IOSpec provides many of the operations this+    library does, however it uses a free monad to do so, which has+    extra allocation overhead. Furthermore, it does not expose enough+    of the internals in order to accurately test real-execution+    semantics, such as relaxed memory.+  .+  See the <https://github.com/barrucadu/dejafu README> for more+  details.++homepage:            https://github.com/barrucadu/dejafu+license:             MIT+license-file:        LICENSE+author:              Michael Walker+maintainer:          mike@barrucadu.co.uk+-- copyright:           +category:            Concurrency+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/barrucadu/dejafu.git++source-repository this+  type:     git+  location: https://github.com/barrucadu/dejafu.git+  tag:      concurrency-0.1.0.0++library+  exposed-modules:     Control.Monad.Conc.Class+                     , Control.Monad.STM.Class++                     , Control.Concurrent.Classy+                     , Control.Concurrent.Classy.Chan+                     , Control.Concurrent.Classy.CRef+                     , Control.Concurrent.Classy.MVar+                     , Control.Concurrent.Classy.QSem+                     , Control.Concurrent.Classy.QSemN+                     , Control.Concurrent.Classy.STM+                     , Control.Concurrent.Classy.STM.TVar+                     , Control.Concurrent.Classy.STM.TMVar+                     , Control.Concurrent.Classy.STM.TChan+                     , Control.Concurrent.Classy.STM.TQueue+                     , Control.Concurrent.Classy.STM.TBQueue+                     , Control.Concurrent.Classy.STM.TArray++  -- other-modules:       +  -- other-extensions:    +  build-depends:       base              >=4.8  && <5+                     , array             >=0.5  && <0.6+                     , atomic-primops    >=0.8  && <0.9+                     , exceptions        >=0.7  && <0.9+                     , monad-control     >=1.0  && <1.1+                     , mtl               >=2.2  && <2.3+                     , stm               >=2.4  && <2.5+                     , transformers      >=0.4  && <0.6+  -- hs-source-dirs:      +  default-language:    Haskell2010+  ghc-options:         -Wall