mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-11-05 06:45:08 +03:00
Make Test.DejaFu.STM an internal module
This commit is contained in:
Michael Walker
parent
81bcb5a351
commit
4ae16eab64
@ -84,6 +84,10 @@ This project is versioned according to the [Package Versioning Policy](https://p
|
||||
|
||||
It is no longer possible to test things in `ST`.
|
||||
|
||||
### Test.DejaFu.STM
|
||||
|
||||
- This is now an internal module. (#155)
|
||||
|
||||
### Miscellaneous
|
||||
|
||||
- The minimum supported version of concurrency is now 1.3.0.0.
|
||||
|
||||
@ -58,8 +58,8 @@ import Test.DejaFu.Schedule
|
||||
import qualified Control.Monad.Conc.Class as C
|
||||
import Test.DejaFu.Conc.Internal
|
||||
import Test.DejaFu.Conc.Internal.Common
|
||||
import Test.DejaFu.Conc.Internal.STM
|
||||
import Test.DejaFu.Internal
|
||||
import Test.DejaFu.STM
|
||||
import Test.DejaFu.Types
|
||||
import Test.DejaFu.Utils
|
||||
|
||||
@ -120,7 +120,7 @@ instance Monad n => C.MonadConc (ConcT r n) where
|
||||
type MVar (ConcT r n) = MVar r
|
||||
type CRef (ConcT r n) = CRef r
|
||||
type Ticket (ConcT r n) = Ticket
|
||||
type STM (ConcT r n) = STMLike n r
|
||||
type STM (ConcT r n) = S n r
|
||||
type ThreadId (ConcT r n) = ThreadId
|
||||
|
||||
-- ----------
|
||||
|
||||
@ -31,11 +31,10 @@ import qualified Data.Sequence as Seq
|
||||
|
||||
import Test.DejaFu.Conc.Internal.Common
|
||||
import Test.DejaFu.Conc.Internal.Memory
|
||||
import Test.DejaFu.Conc.Internal.STM
|
||||
import Test.DejaFu.Conc.Internal.Threading
|
||||
import Test.DejaFu.Internal
|
||||
import Test.DejaFu.Schedule
|
||||
import Test.DejaFu.STM (Result(..),
|
||||
runTransaction)
|
||||
import Test.DejaFu.Types
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@ -12,15 +12,16 @@
|
||||
--
|
||||
-- Common types and utility functions for deterministic execution of
|
||||
-- 'MonadConc' implementations. This module is NOT considered to form
|
||||
-- part of the public interface of this library.
|
||||
module Test.DejaFu.Conc.Internal.Common where
|
||||
|
||||
import Control.Exception (Exception, MaskingState(..))
|
||||
import Data.Map.Strict (Map)
|
||||
import Test.DejaFu.STM (STMLike)
|
||||
import Control.Exception (Exception, MaskingState(..))
|
||||
import Data.Map.Strict (Map)
|
||||
import Test.DejaFu.Conc.Internal.STM (S)
|
||||
import Test.DejaFu.Types
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -140,7 +141,7 @@ data Action n r =
|
||||
| forall a. AMasking MaskingState ((forall b. M n r b -> M n r b) -> M n r a) (a -> Action n r)
|
||||
| AResetMask Bool Bool MaskingState (Action n r)
|
||||
|
||||
| forall a. AAtom (STMLike n r a) (a -> Action n r)
|
||||
| forall a. AAtom (S n r a) (a -> Action n r)
|
||||
| ALift (n (Action n r))
|
||||
| AYield (Action n r)
|
||||
| ADelay Int (Action n r)
|
||||
|
||||
@ -1,70 +1,88 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- Must come after TypeFamilies
|
||||
{-# LANGUAGE NoMonoLocalBinds #-}
|
||||
|
||||
-- |
|
||||
-- Module : Test.DejaFu.STM.Internal
|
||||
-- Copyright : (c) 2016 Michael Walker
|
||||
-- Module : Test.DejaFu.Conc.Internal.STM
|
||||
-- Copyright : (c) 2017 Michael Walker
|
||||
-- License : MIT
|
||||
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
|
||||
-- Stability : experimental
|
||||
-- Portability : CPP, ExistentialQuantification, MultiParamTypeClasses, RankNTypes
|
||||
-- Portability : CPP, ExistentialQuantification, MultiParamTypeClasses, NoMonoLocalBinds, TypeFamilies
|
||||
--
|
||||
-- 'MonadSTM' testing implementation, internal types and
|
||||
-- definitions. This module is NOT considered to form part of the
|
||||
-- public interface of this library.
|
||||
module Test.DejaFu.STM.Internal where
|
||||
-- 'MonadSTM' testing implementation, internal types and definitions.
|
||||
-- This module is NOT considered to form part of the public interface
|
||||
-- of this library.
|
||||
module Test.DejaFu.Conc.Internal.STM where
|
||||
|
||||
import Control.DeepSeq (NFData(..))
|
||||
import Control.Exception (Exception, SomeException, fromException,
|
||||
toException)
|
||||
import Control.Monad.Ref (MonadRef, newRef, readRef, writeRef)
|
||||
import Data.List (nub)
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Exception (Exception, SomeException,
|
||||
fromException, toException)
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
|
||||
import Control.Monad.Ref (MonadRef, newRef, readRef, writeRef)
|
||||
import Data.List (nub)
|
||||
|
||||
import qualified Control.Monad.STM.Class as C
|
||||
import Test.DejaFu.Internal
|
||||
import Test.DejaFu.Types
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- The @STMLike@ monad
|
||||
-- * The @S@ monad
|
||||
|
||||
-- | The underlying monad is based on continuations over primitive
|
||||
-- actions.
|
||||
--
|
||||
-- This is not @Cont@ because we want to give it a custom @MonadFail@
|
||||
-- instance.
|
||||
newtype M n r a = M { runM :: (a -> STMAction n r) -> STMAction n r }
|
||||
newtype S n r a = S { runSTM :: (a -> STMAction n r) -> STMAction n r }
|
||||
|
||||
instance Functor (M n r) where
|
||||
fmap f m = M $ \ c -> runM m (c . f)
|
||||
instance Functor (S n r) where
|
||||
fmap f m = S $ \c -> runSTM m (c . f)
|
||||
|
||||
instance Applicative (M n r) where
|
||||
pure x = M $ \c -> c x
|
||||
f <*> v = M $ \c -> runM f (\g -> runM v (c . g))
|
||||
instance Applicative (S n r) where
|
||||
pure x = S $ \c -> c x
|
||||
f <*> v = S $ \c -> runSTM f (\g -> runSTM v (c . g))
|
||||
|
||||
instance Monad (M n r) where
|
||||
instance Monad (S n r) where
|
||||
return = pure
|
||||
m >>= k = M $ \c -> runM m (\x -> runM (k x) c)
|
||||
m >>= k = S $ \c -> runSTM m (\x -> runSTM (k x) c)
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
fail = Fail.fail
|
||||
|
||||
-- | @since 0.7.1.2
|
||||
instance Fail.MonadFail (M n r) where
|
||||
instance Fail.MonadFail (S n r) where
|
||||
#endif
|
||||
fail e = cont (\_ -> SThrow (MonadFailException e))
|
||||
fail e = S $ \_ -> SThrow (MonadFailException e)
|
||||
|
||||
-- | Construct a continuation-passing operation from a function.
|
||||
cont :: ((a -> STMAction n r) -> STMAction n r) -> M n r a
|
||||
cont = M
|
||||
instance MonadThrow (S n r) where
|
||||
throwM e = S $ \_ -> SThrow e
|
||||
|
||||
-- | Run a CPS computation with the given final computation.
|
||||
runCont :: M n r a -> (a -> STMAction n r) -> STMAction n r
|
||||
runCont = runM
|
||||
instance MonadCatch (S n r) where
|
||||
catch stm handler = S $ SCatch handler stm
|
||||
|
||||
instance Alternative (S n r) where
|
||||
a <|> b = S $ SOrElse a b
|
||||
empty = S $ const SRetry
|
||||
|
||||
instance MonadPlus (S n r)
|
||||
|
||||
instance C.MonadSTM (S n r) where
|
||||
type TVar (S n r) = TVar r
|
||||
|
||||
newTVarN n = S . SNew n
|
||||
|
||||
readTVar = S . SRead
|
||||
|
||||
writeTVar tvar a = S $ \c -> SWrite tvar a (c ())
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * Primitive actions
|
||||
@ -72,10 +90,10 @@ runCont = runM
|
||||
-- | STM transactions are represented as a sequence of primitive
|
||||
-- actions.
|
||||
data STMAction n r
|
||||
= forall a e. Exception e => SCatch (e -> M n r a) (M n r a) (a -> STMAction n r)
|
||||
= forall a e. Exception e => SCatch (e -> S n r a) (S n r a) (a -> STMAction n r)
|
||||
| forall a. SRead (TVar r a) (a -> STMAction n r)
|
||||
| forall a. SWrite (TVar r a) a (STMAction n r)
|
||||
| forall a. SOrElse (M n r a) (M n r a) (a -> STMAction n r)
|
||||
| forall a. SOrElse (S n r a) (S n r a) (a -> STMAction n r)
|
||||
| forall a. SNew String a (TVar r a -> STMAction n r)
|
||||
| forall e. Exception e => SThrow e
|
||||
| SRetry
|
||||
@ -94,8 +112,6 @@ newtype TVar r a = TVar (TVarId, r a)
|
||||
|
||||
-- | The result of an STM transaction, along with which 'TVar's it
|
||||
-- touched whilst executing.
|
||||
--
|
||||
-- @since 0.1.0.0
|
||||
data Result a =
|
||||
Success [TVarId] [TVarId] a
|
||||
-- ^ The transaction completed successfully, reading the first list
|
||||
@ -108,41 +124,35 @@ data Result a =
|
||||
-- ^ The transaction aborted by throwing an exception.
|
||||
deriving Show
|
||||
|
||||
-- | This only reduces a 'SomeException' to WHNF.
|
||||
--
|
||||
-- @since 0.5.1.0
|
||||
instance NFData a => NFData (Result a) where
|
||||
rnf (Success tr1 tr2 a) = rnf (tr1, tr2, a)
|
||||
rnf (Retry tr) = rnf tr
|
||||
rnf (Exception e) = e `seq` ()
|
||||
|
||||
-- | Check if a 'Result' is a @Success@.
|
||||
isSTMSuccess :: Result a -> Bool
|
||||
isSTMSuccess (Success _ _ _) = True
|
||||
isSTMSuccess _ = False
|
||||
|
||||
instance Functor Result where
|
||||
fmap f (Success rs ws a) = Success rs ws $ f a
|
||||
fmap _ (Retry rs) = Retry rs
|
||||
fmap _ (Exception e) = Exception e
|
||||
|
||||
instance Foldable Result where
|
||||
foldMap f (Success _ _ a) = f a
|
||||
foldMap _ _ = mempty
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * Execution
|
||||
|
||||
-- | Run a transaction, returning the result and new initial 'TVarId'.
|
||||
-- If the transaction failed, any effects are undone.
|
||||
runTransaction :: MonadRef r n
|
||||
=> S n r a
|
||||
-> IdSource
|
||||
-> n (Result a, IdSource, [TAction])
|
||||
runTransaction ma tvid = do
|
||||
(res, _, tvid', trace) <- doTransaction ma tvid
|
||||
pure (res, tvid', trace)
|
||||
|
||||
-- | Run a STM transaction, returning an action to undo its effects.
|
||||
doTransaction :: MonadRef r n => M n r a -> IdSource -> n (Result a, n (), IdSource, [TAction])
|
||||
--
|
||||
-- If the transaction fails, its effects will automatically be undone,
|
||||
-- so the undo action returned will be @pure ()@.
|
||||
doTransaction :: MonadRef r n
|
||||
=> S n r a
|
||||
-> IdSource
|
||||
-> n (Result a, n (), IdSource, [TAction])
|
||||
doTransaction ma idsource = do
|
||||
(c, ref) <- runRefCont SStop (Just . Right) (runCont ma)
|
||||
(c, ref) <- runRefCont SStop (Just . Right) (runSTM ma)
|
||||
(idsource', undo, readen, written, trace) <- go ref c (pure ()) idsource [] [] []
|
||||
res <- readRef ref
|
||||
|
||||
case res of
|
||||
Just (Right val) -> pure (Success (nub readen) (nub written) val, undo, idsource', reverse trace)
|
||||
|
||||
Just (Left exc) -> undo >> pure (Exception exc, pure (), idsource, reverse trace)
|
||||
Nothing -> undo >> pure (Retry $ nub readen, pure (), idsource, reverse trace)
|
||||
|
||||
@ -168,7 +178,10 @@ doTransaction ma idsource = do
|
||||
_ -> go ref newAct newUndo newIDSource newReaden newWritten newSofar
|
||||
|
||||
-- | Run a transaction for one step.
|
||||
stepTrans :: MonadRef r n => STMAction n r -> IdSource -> n (STMAction n r, n (), IdSource, [TVarId], [TVarId], TAction)
|
||||
stepTrans :: MonadRef r n
|
||||
=> STMAction n r
|
||||
-> IdSource
|
||||
-> n (STMAction n r, n (), IdSource, [TVarId], [TVarId], TAction)
|
||||
stepTrans act idsource = case act of
|
||||
SCatch h stm c -> stepCatch h stm c
|
||||
SRead ref c -> stepRead ref c
|
||||
@ -1,121 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- |
|
||||
-- Module : Test.DejaFu.STM
|
||||
-- Copyright : (c) 2016 Michael Walker
|
||||
-- License : MIT
|
||||
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
|
||||
-- Stability : experimental
|
||||
-- Portability : CPP, GeneralizedNewtypeDeriving, TypeFamilies
|
||||
--
|
||||
-- A 'MonadSTM' implementation, which can be run on top of 'IO' or
|
||||
-- 'ST'.
|
||||
module Test.DejaFu.STM
|
||||
( -- * The @STMLike@ Monad
|
||||
STMLike
|
||||
, STMST
|
||||
, STMIO
|
||||
|
||||
-- * Executing Transactions
|
||||
, Result(..)
|
||||
, TAction(..)
|
||||
, TVarId
|
||||
, runTransaction
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus(..), unless)
|
||||
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
|
||||
import Control.Monad.Ref (MonadRef)
|
||||
import Control.Monad.ST (ST)
|
||||
import Data.IORef (IORef)
|
||||
import Data.STRef (STRef)
|
||||
|
||||
import qualified Control.Monad.STM.Class as C
|
||||
import Test.DejaFu.Internal
|
||||
import Test.DejaFu.STM.Internal
|
||||
import Test.DejaFu.Types
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
#endif
|
||||
|
||||
-- | @since 0.3.0.0
|
||||
newtype STMLike n r a = S { runSTM :: M n r a } deriving (Functor, Applicative, Monad)
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
-- | @since 0.9.1.0
|
||||
instance Fail.MonadFail (STMLike r n) where
|
||||
fail = S . fail
|
||||
#endif
|
||||
|
||||
-- | Create a new STM continuation.
|
||||
toSTM :: ((a -> STMAction n r) -> STMAction n r) -> STMLike n r a
|
||||
toSTM = S . cont
|
||||
|
||||
-- | A 'MonadSTM' implementation using @ST@, it encapsulates a single
|
||||
-- atomic transaction. The environment, that is, the collection of
|
||||
-- defined 'TVar's is implicit, there is no list of them, they exist
|
||||
-- purely as references. This makes the types simpler, but means you
|
||||
-- can't really get an aggregate of them (if you ever wanted to for
|
||||
-- some reason).
|
||||
--
|
||||
-- @since 0.3.0.0
|
||||
type STMST t = STMLike (ST t) (STRef t)
|
||||
|
||||
-- | A 'MonadSTM' implementation using @ST@, it encapsulates a single
|
||||
-- atomic transaction. The environment, that is, the collection of
|
||||
-- defined 'TVar's is implicit, there is no list of them, they exist
|
||||
-- purely as references. This makes the types simpler, but means you
|
||||
-- can't really get an aggregate of them (if you ever wanted to for
|
||||
-- some reason).
|
||||
--
|
||||
-- @since 0.3.0.0
|
||||
type STMIO = STMLike IO IORef
|
||||
|
||||
instance MonadThrow (STMLike n r) where
|
||||
throwM = toSTM . const . SThrow
|
||||
|
||||
instance MonadCatch (STMLike n r) where
|
||||
catch (S stm) handler = toSTM (SCatch (runSTM . handler) stm)
|
||||
|
||||
-- | @since 0.7.2.0
|
||||
instance Alternative (STMLike n r) where
|
||||
S a <|> S b = toSTM (SOrElse a b)
|
||||
empty = toSTM (const SRetry)
|
||||
|
||||
-- | @since 0.7.2.0
|
||||
instance MonadPlus (STMLike n r)
|
||||
|
||||
instance C.MonadSTM (STMLike n r) where
|
||||
type TVar (STMLike n r) = TVar r
|
||||
|
||||
#if MIN_VERSION_concurrency(1,2,0)
|
||||
-- retry and orElse are top-level definitions in
|
||||
-- Control.Monad.STM.Class in 1.2 and up
|
||||
#else
|
||||
retry = empty
|
||||
orElse = (<|>)
|
||||
#endif
|
||||
|
||||
newTVarN n = toSTM . SNew n
|
||||
|
||||
readTVar = toSTM . SRead
|
||||
|
||||
writeTVar tvar a = toSTM (\c -> SWrite tvar a (c ()))
|
||||
|
||||
-- | Run a transaction, returning the result and new initial
|
||||
-- 'TVarId'. If the transaction ended by calling 'retry', any 'TVar'
|
||||
-- modifications are undone.
|
||||
--
|
||||
-- @since 0.4.0.0
|
||||
runTransaction :: MonadRef r n
|
||||
=> STMLike n r a -> IdSource -> n (Result a, IdSource, [TAction])
|
||||
runTransaction ma tvid = do
|
||||
(res, undo, tvid', trace) <- doTransaction (runSTM ma) tvid
|
||||
|
||||
unless (isSTMSuccess res) undo
|
||||
|
||||
pure (res, tvid', trace)
|
||||
@ -41,7 +41,6 @@ library
|
||||
, Test.DejaFu.Defaults
|
||||
, Test.DejaFu.Refinement
|
||||
, Test.DejaFu.SCT
|
||||
, Test.DejaFu.STM
|
||||
, Test.DejaFu.Schedule
|
||||
, Test.DejaFu.Types
|
||||
, Test.DejaFu.Utils
|
||||
@ -49,10 +48,10 @@ library
|
||||
, Test.DejaFu.Conc.Internal
|
||||
, Test.DejaFu.Conc.Internal.Common
|
||||
, Test.DejaFu.Conc.Internal.Memory
|
||||
, Test.DejaFu.Conc.Internal.STM
|
||||
, Test.DejaFu.Conc.Internal.Threading
|
||||
, Test.DejaFu.Internal
|
||||
, Test.DejaFu.SCT.Internal
|
||||
, Test.DejaFu.STM.Internal
|
||||
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user