mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-11-04 22:13:26 +03:00
Add an HLint2 config file & fix warnings.
This commit is contained in:
Michael Walker
parent
0080678a65
commit
5cd55a1921
19
.hlint.yaml
Normal file
19
.hlint.yaml
Normal file
@ -0,0 +1,19 @@
|
||||
# HLint configuration file
|
||||
# https://github.com/ndmitchell/hlint
|
||||
##########################
|
||||
|
||||
# Module export lists should generally be preferred, but may be
|
||||
# omitted if the module is small or internal.
|
||||
- ignore: {name: Use module export list}
|
||||
|
||||
# Record patterns are just ugly.
|
||||
- ignore: {name: Use record patterns}
|
||||
|
||||
# GHC treats infix $ specially wrt type checking, so that things like
|
||||
# "runST $ do ..." work even though they're impredicative.
|
||||
# Unfortunately, this means that HLint's "avoid lambda" warning for
|
||||
# this module would lead to code which no longer compiles!
|
||||
- ignore: {name: Avoid lambda, within: Test.DejaFu.Conc}
|
||||
|
||||
# Prefer applicative operators over monadic ones.
|
||||
- suggest: {name: Generalise monadic functions, lhs: return, rhs: pure}
|
||||
@ -36,5 +36,3 @@ 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) #-}
|
||||
|
||||
@ -142,7 +142,7 @@ instance MonadConc m => Functor (Concurrently m) where
|
||||
|
||||
-- | @since 1.1.1.0
|
||||
instance MonadConc m => Applicative (Concurrently m) where
|
||||
pure = Concurrently . return
|
||||
pure = Concurrently . pure
|
||||
|
||||
Concurrently fs <*> Concurrently as =
|
||||
Concurrently $ (\(f, a) -> f a) <$> concurrently fs as
|
||||
@ -199,8 +199,7 @@ asyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> m (Async m a)
|
||||
asyncUsing doFork action = do
|
||||
var <- atomically newEmptyTMVar
|
||||
tid <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putTMVar var
|
||||
|
||||
return $ Async tid (readTMVar var)
|
||||
pure (Async tid (readTMVar var))
|
||||
|
||||
-- | Fork a thread with the given forking function and give it an
|
||||
-- action to unmask exceptions
|
||||
@ -208,8 +207,7 @@ asyncUnmaskUsing :: MonadConc m => (((forall b. m b -> m b) -> m ()) -> m (Threa
|
||||
asyncUnmaskUsing doFork action = do
|
||||
var <- atomically newEmptyTMVar
|
||||
tid <- doFork $ \restore -> try (action restore) >>= atomically . putTMVar var
|
||||
|
||||
return $ Async tid (readTMVar var)
|
||||
pure (Async tid (readTMVar var))
|
||||
|
||||
-- | Spawn an asynchronous action in a separate thread, and pass its
|
||||
-- @Async@ handle to the supplied function. When the function returns
|
||||
@ -245,36 +243,30 @@ withAsyncWithUnmask = withAsyncUnmaskUsing forkWithUnmask
|
||||
withAsyncOnWithUnmask :: MonadConc m => Int -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
|
||||
withAsyncOnWithUnmask i = withAsyncUnmaskUsing (forkOnWithUnmask i)
|
||||
|
||||
-- | Fork a thread with the given forking function and kill it when
|
||||
-- the inner action completes.
|
||||
--
|
||||
-- The 'bracket' version appears to hang, even with just IO stuff and
|
||||
-- using the normal async package. Curious.
|
||||
-- | Helper for 'withAsync' and 'withAsyncOn': fork a thread with the
|
||||
-- given forking function and kill it when the inner action completes.
|
||||
withAsyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
|
||||
withAsyncUsing doFork action inner = do
|
||||
var <- atomically newEmptyTMVar
|
||||
tid <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putTMVar var
|
||||
withAsyncDo (Async tid (readTMVar var)) inner
|
||||
|
||||
let a = Async tid (readTMVar var)
|
||||
|
||||
res <- inner a `catchAll` (\e -> uninterruptibleCancel a >> throw e)
|
||||
cancel a
|
||||
|
||||
return res
|
||||
|
||||
-- | Fork a thread with the given forking function, give it an action
|
||||
-- to unmask exceptions, and kill it when the inner action completed.
|
||||
-- | Helper for 'withAsyncWithUnmask' and 'withAsyncOnWithUnmask':
|
||||
-- fork a thread with the given forking function, give it an action to
|
||||
-- unmask exceptions, and kill it when the inner action completed.
|
||||
withAsyncUnmaskUsing :: MonadConc m => (((forall x. m x -> m x) -> m ()) -> m (ThreadId m)) -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
|
||||
withAsyncUnmaskUsing doFork action inner = do
|
||||
var <- atomically newEmptyTMVar
|
||||
tid <- doFork $ \restore -> try (action restore) >>= atomically . putTMVar var
|
||||
withAsyncDo (Async tid (readTMVar var)) inner
|
||||
|
||||
let a = Async tid (readTMVar var)
|
||||
|
||||
-- | Helper for 'withAsyncUsing' and 'withAsyncUnmaskUsing': run the
|
||||
-- inner action and kill the async thread when done.
|
||||
withAsyncDo :: MonadConc m => Async m a -> (Async m a -> m b) -> m b
|
||||
withAsyncDo a inner = do
|
||||
res <- inner a `catchAll` (\e -> uninterruptibleCancel a >> throw e)
|
||||
cancel a
|
||||
|
||||
return res
|
||||
pure res
|
||||
|
||||
catchAll :: MonadConc m => m a -> (SomeException -> m a) -> m a
|
||||
catchAll = catch
|
||||
@ -298,7 +290,7 @@ wait = atomically . waitSTM
|
||||
waitSTM :: MonadConc m => Async m a -> STM m a
|
||||
waitSTM a = do
|
||||
r <- waitCatchSTM a
|
||||
either throwSTM return r
|
||||
either throwSTM pure r
|
||||
|
||||
-- | Check whether an 'Async' has completed yet. If it has not
|
||||
-- completed yet, then the result is @Nothing@, otherwise the result
|
||||
@ -315,7 +307,7 @@ poll = atomically . pollSTM
|
||||
--
|
||||
-- @since 1.1.1.0
|
||||
pollSTM :: MonadConc m => Async m a -> STM m (Maybe (Either SomeException a))
|
||||
pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing
|
||||
pollSTM (Async _ w) = (Just <$> w) `orElse` pure Nothing
|
||||
|
||||
-- | Wait for an asynchronous action to complete, and return either
|
||||
-- @Left e@ if the action raised an exception @e@, or @Right a@ if it
|
||||
@ -391,7 +383,7 @@ waitAny = atomically . waitAnySTM
|
||||
--
|
||||
-- @since 1.1.1.0
|
||||
waitAnySTM :: MonadConc m => [Async m a] -> STM m (Async m a, a)
|
||||
waitAnySTM = foldr (orElse . (\a -> do r <- waitSTM a; return (a, r))) retry
|
||||
waitAnySTM = foldr (orElse . (\a -> do r <- waitSTM a; pure (a, r))) retry
|
||||
|
||||
-- | Wait for any of the supplied asynchronous operations to complete.
|
||||
-- The value returned is a pair of the 'Async' that completed, and the
|
||||
@ -409,7 +401,7 @@ waitAnyCatch = atomically . waitAnyCatchSTM
|
||||
--
|
||||
-- @since 1.1.1.0
|
||||
waitAnyCatchSTM :: MonadConc m => [Async m a] -> STM m (Async m a, Either SomeException a)
|
||||
waitAnyCatchSTM = foldr (orElse . (\a -> do r <- waitCatchSTM a; return (a, r))) retry
|
||||
waitAnyCatchSTM = foldr (orElse . (\a -> do r <- waitCatchSTM a; pure (a, r))) retry
|
||||
|
||||
-- | Like 'waitAny', but also cancels the other asynchronous
|
||||
-- operations as soon as one has completed.
|
||||
@ -503,7 +495,7 @@ waitBothSTM :: MonadConc m => Async m a -> Async m b -> STM m (a, b)
|
||||
waitBothSTM left right = do
|
||||
a <- waitSTM left `orElse` (waitSTM right >> retry)
|
||||
b <- waitSTM right
|
||||
return (a, b)
|
||||
pure (a, b)
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
@ -521,7 +513,7 @@ link (Async _ w) = do
|
||||
r <- atomically w
|
||||
case r of
|
||||
Left e -> throwTo me e
|
||||
_ -> return ()
|
||||
_ -> pure ()
|
||||
|
||||
-- | Link two @Async@s together, such that if either raises an
|
||||
-- exception, the same exception is re-thrown in the other @Async@.
|
||||
@ -534,7 +526,7 @@ link2 left@(Async tl _) right@(Async tr _) =
|
||||
case r of
|
||||
Left (Left e) -> throwTo tr e
|
||||
Right (Left e) -> throwTo tl e
|
||||
_ -> return ()
|
||||
_ -> pure ()
|
||||
|
||||
-- | Fork a thread that runs the supplied action, and if it raises an
|
||||
-- exception, re-runs the action. The thread terminates only when the
|
||||
@ -545,7 +537,7 @@ forkRepeat action = mask $ \restore ->
|
||||
r <- (try :: MonadConc m => m a -> m (Either SomeException a)) $ restore action
|
||||
case r of
|
||||
Left _ -> go
|
||||
_ -> return ()
|
||||
_ -> pure ()
|
||||
in fork go
|
||||
|
||||
|
||||
@ -567,7 +559,7 @@ race left right = concurrently' left right collect where
|
||||
e <- takeMVar m
|
||||
case e of
|
||||
Left ex -> throw ex
|
||||
Right r -> return r
|
||||
Right r -> pure r
|
||||
|
||||
-- | Like 'race', but the result is ignored.
|
||||
--
|
||||
@ -593,8 +585,8 @@ race_ a b = void $ race a b
|
||||
-- @since 1.1.1.0
|
||||
concurrently :: MonadConc m => m a -> m b -> m (a, b)
|
||||
concurrently left right = concurrently' left right (collect []) where
|
||||
collect [Left a, Right b] _ = return (a, b)
|
||||
collect [Right b, Left a] _ = return (a, b)
|
||||
collect [Left a, Right b] _ = pure (a, b)
|
||||
collect [Right b, Left a] _ = pure (a, b)
|
||||
collect xs m = do
|
||||
e <- takeMVar m
|
||||
case e of
|
||||
@ -633,7 +625,7 @@ concurrently' left right collect = do
|
||||
|
||||
stop
|
||||
|
||||
return r
|
||||
pure r
|
||||
|
||||
-- | Maps a @MonadConc@-performing function over any @Traversable@
|
||||
-- data type, performing all the @MonadConc@ actions concurrently, and
|
||||
|
||||
@ -60,7 +60,7 @@ swapMVar :: MonadConc m => MVar m a -> a -> m a
|
||||
swapMVar cvar a = mask_ $ do
|
||||
old <- takeMVar cvar
|
||||
putMVar cvar a
|
||||
return old
|
||||
pure old
|
||||
|
||||
-- | Check if a @MVar@ is empty.
|
||||
--
|
||||
@ -69,8 +69,8 @@ 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
|
||||
Just val' -> putMVar cvar val' >> pure True
|
||||
Nothing -> pure False
|
||||
|
||||
-- | Operate on the contents of a @MVar@, replacing the contents after
|
||||
-- finishing. This operation is exception-safe: it will replace the
|
||||
@ -85,7 +85,7 @@ withMVar cvar f = mask $ \restore -> do
|
||||
out <- restore (f val) `onException` putMVar cvar val
|
||||
putMVar cvar val
|
||||
|
||||
return out
|
||||
pure out
|
||||
|
||||
-- | Like 'withMVar', but the @IO@ action in the second argument is
|
||||
-- executed with asynchronous exceptions masked.
|
||||
@ -98,7 +98,7 @@ withMVarMasked cvar f = mask_ $ do
|
||||
out <- f val `onException` putMVar cvar val
|
||||
putMVar cvar val
|
||||
|
||||
return out
|
||||
pure out
|
||||
|
||||
-- | An exception-safe wrapper for modifying the contents of a @MVar@.
|
||||
-- Like 'withMVar', 'modifyMVar' will replace the original contents of
|
||||
@ -121,7 +121,7 @@ modifyMVar cvar f = mask $ \restore -> do
|
||||
val <- takeMVar cvar
|
||||
(val', out) <- restore (f val) `onException` putMVar cvar val
|
||||
putMVar cvar val'
|
||||
return out
|
||||
pure out
|
||||
|
||||
-- | Like 'modifyMVar_', but the @IO@ action in the second argument is
|
||||
-- executed with asynchronous exceptions masked.
|
||||
@ -141,4 +141,4 @@ modifyMVarMasked cvar f = mask_ $ do
|
||||
val <- takeMVar cvar
|
||||
(val', out) <- f val `onException` putMVar cvar val
|
||||
putMVar cvar val'
|
||||
return out
|
||||
pure out
|
||||
|
||||
@ -24,5 +24,3 @@ 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) #-}
|
||||
|
||||
@ -113,7 +113,7 @@ peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
|
||||
peekTBQueue c = do
|
||||
x <- readTBQueue c
|
||||
unGetTBQueue c x
|
||||
return x
|
||||
pure x
|
||||
|
||||
-- | A version of 'peekTBQueue' which does not retry. Instead it
|
||||
-- returns @Nothing@ if no value is available.
|
||||
|
||||
@ -125,7 +125,7 @@ dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a)
|
||||
dupTChan (TChan _ writeT) = do
|
||||
hole <- readTVar writeT
|
||||
readT' <- newTVar hole
|
||||
return (TChan readT' writeT)
|
||||
pure (TChan readT' writeT)
|
||||
|
||||
-- | Put a data item back onto a channel, where it will be the next
|
||||
-- item read.
|
||||
|
||||
@ -57,7 +57,7 @@ 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
|
||||
pure (TMVar ctvar)
|
||||
|
||||
-- | Create a new empty 'TMVar'.
|
||||
--
|
||||
@ -75,7 +75,7 @@ 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
|
||||
pure (TMVar ctvar)
|
||||
|
||||
-- | Take the contents of a 'TMVar', or 'retry' if it is empty.
|
||||
--
|
||||
@ -83,7 +83,7 @@ newEmptyTMVarN n = do
|
||||
takeTMVar :: MonadSTM stm => TMVar stm a -> stm a
|
||||
takeTMVar ctmvar = do
|
||||
taken <- tryTakeTMVar ctmvar
|
||||
maybe retry return taken
|
||||
maybe retry pure taken
|
||||
|
||||
-- | Write to a 'TMVar', or 'retry' if it is full.
|
||||
--
|
||||
@ -99,7 +99,7 @@ putTMVar ctmvar a = do
|
||||
readTMVar :: MonadSTM stm => TMVar stm a -> stm a
|
||||
readTMVar ctmvar = do
|
||||
readed <- tryReadTMVar ctmvar
|
||||
maybe retry return readed
|
||||
maybe retry pure readed
|
||||
|
||||
-- | Try to take the contents of a 'TMVar', returning 'Nothing' if it
|
||||
-- is empty.
|
||||
@ -109,7 +109,7 @@ tryTakeTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a)
|
||||
tryTakeTMVar (TMVar ctvar) = do
|
||||
val <- readTVar ctvar
|
||||
when (isJust val) $ writeTVar ctvar Nothing
|
||||
return val
|
||||
pure val
|
||||
|
||||
-- | Try to write to a 'TMVar', returning 'False' if it is full.
|
||||
--
|
||||
@ -118,7 +118,7 @@ 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
|
||||
pure (isNothing val)
|
||||
|
||||
-- | Try to read from a 'TMVar' without emptying, returning 'Nothing'
|
||||
-- if it is empty.
|
||||
@ -141,4 +141,4 @@ swapTMVar :: MonadSTM stm => TMVar stm a -> a -> stm a
|
||||
swapTMVar ctmvar a = do
|
||||
val <- takeTMVar ctmvar
|
||||
putTMVar ctmvar a
|
||||
return val
|
||||
pure val
|
||||
|
||||
@ -54,7 +54,7 @@ swapTVar :: MonadSTM stm => TVar stm a -> a -> stm a
|
||||
swapTVar ctvar a = do
|
||||
old <- readTVar ctvar
|
||||
writeTVar ctvar a
|
||||
return old
|
||||
pure old
|
||||
|
||||
-- | Set the value of returned 'TVar' to @True@ after a given number
|
||||
-- of microseconds. The caveats associated with 'threadDelay' also
|
||||
|
||||
@ -91,8 +91,6 @@ 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
|
||||
@ -167,11 +165,11 @@ class ( Applicative m, Monad m
|
||||
-- | Fork a computation to happen concurrently. Communication may
|
||||
-- happen over @MVar@s.
|
||||
--
|
||||
-- > fork ma = forkWithUnmask (\_ -> ma)
|
||||
-- > fork ma = forkWithUnmask (const ma)
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
fork :: m () -> m (ThreadId m)
|
||||
fork ma = forkWithUnmask (\_ -> ma)
|
||||
fork ma = forkWithUnmask (const ma)
|
||||
|
||||
-- | Like 'fork', but the child thread is passed a function that can
|
||||
-- be used to unmask asynchronous exceptions. This function should
|
||||
@ -202,11 +200,11 @@ class ( Applicative m, Monad m
|
||||
-- implementation dependent. The int is interpreted modulo to the
|
||||
-- total number of capabilities as returned by 'getNumCapabilities'.
|
||||
--
|
||||
-- > forkOn c ma = forkOnWithUnmask c (\_ -> ma)
|
||||
-- > forkOn c ma = forkOnWithUnmask c (const ma)
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
forkOn :: Int -> m () -> m (ThreadId m)
|
||||
forkOn c ma = forkOnWithUnmask c (\_ -> ma)
|
||||
forkOn c ma = forkOnWithUnmask c (const ma)
|
||||
|
||||
-- | Like 'forkWithUnmask', but the child thread is pinned to the
|
||||
-- given CPU, as with 'forkOn'.
|
||||
@ -477,7 +475,7 @@ killThread tid = throwTo tid ThreadKilled
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
forkN :: MonadConc m => String -> m () -> m (ThreadId m)
|
||||
forkN name ma = forkWithUnmaskN name (\_ -> ma)
|
||||
forkN name ma = forkWithUnmaskN name (const ma)
|
||||
|
||||
-- | Like 'forkOn', but the thread is given a name which may be used
|
||||
-- to present more useful debugging information.
|
||||
@ -488,7 +486,7 @@ forkN name ma = forkWithUnmaskN name (\_ -> ma)
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
forkOnN :: MonadConc m => String -> Int -> m () -> m (ThreadId m)
|
||||
forkOnN name i ma = forkOnWithUnmaskN name i (\_ -> ma)
|
||||
forkOnN name i ma = forkOnWithUnmaskN name i (const ma)
|
||||
|
||||
-- Bound Threads
|
||||
|
||||
|
||||
@ -362,7 +362,7 @@ dejafusWay :: (Show a, RandomGen g)
|
||||
dejafusWay way memtype conc tests = do
|
||||
let traces = runST (runSCT way memtype conc)
|
||||
results <- mapM (\(name, test) -> doTest name $ test traces) tests
|
||||
return $ and results
|
||||
pure (and results)
|
||||
|
||||
-- | Variant of 'dejafu' for computations which do 'IO'.
|
||||
dejafuIO :: Show a => ConcIO a -> (String, Predicate a) -> IO Bool
|
||||
@ -382,7 +382,7 @@ dejafusWayIO :: (Show a, RandomGen g) => Way g -> MemType -> ConcIO a -> [(Strin
|
||||
dejafusWayIO way memtype concio tests = do
|
||||
traces <- runSCT way memtype concio
|
||||
results <- mapM (\(name, test) -> doTest name $ test traces) tests
|
||||
return $ and results
|
||||
pure (and results)
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
@ -687,7 +687,7 @@ doTest name result = do
|
||||
when (moreThan 5 failures) $
|
||||
putStrLn (indent "...")
|
||||
|
||||
return $ _pass result
|
||||
pure (_pass result)
|
||||
|
||||
-- | Check if a list is longer than some value, without needing to
|
||||
-- compute the entire length.
|
||||
|
||||
@ -64,9 +64,6 @@ import Test.DejaFu.Conc.Internal
|
||||
import Test.DejaFu.Conc.Internal.Common
|
||||
import Test.DejaFu.STM
|
||||
|
||||
{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
newtype Conc n r a = C { unC :: M n r a } deriving (Functor, Applicative, Monad)
|
||||
|
||||
-- | A 'MonadConc' implementation using @ST@, this should be preferred
|
||||
@ -89,7 +86,7 @@ instance Ba.MonadBase IO ConcIO where
|
||||
liftBase = IO.liftIO
|
||||
|
||||
instance Re.MonadRef (CRef r) (Conc n r) where
|
||||
newRef a = toConc (\c -> ANewCRef "" a c)
|
||||
newRef a = toConc (ANewCRef "" a)
|
||||
|
||||
readRef ref = toConc (AReadCRef ref)
|
||||
|
||||
@ -134,7 +131,7 @@ instance Monad n => C.MonadConc (Conc n r) where
|
||||
|
||||
-- ----------
|
||||
|
||||
newCRefN n a = toConc (\c -> ANewCRef n a c)
|
||||
newCRefN n a = toConc (ANewCRef n a)
|
||||
|
||||
readCRef ref = toConc (AReadCRef ref)
|
||||
readForCAS ref = toConc (AReadCRefCas ref)
|
||||
@ -149,7 +146,7 @@ instance Monad n => C.MonadConc (Conc n r) where
|
||||
|
||||
-- ----------
|
||||
|
||||
newEmptyMVarN n = toConc (\c -> ANewMVar n c)
|
||||
newEmptyMVarN n = toConc (ANewMVar n)
|
||||
|
||||
putMVar var a = toConc (\c -> APutMVar var a (c ()))
|
||||
readMVar var = toConc (AReadMVar var)
|
||||
|
||||
@ -34,9 +34,6 @@ import Test.DejaFu.Conc.Internal.Threading
|
||||
import Test.DejaFu.Schedule
|
||||
import Test.DejaFu.STM (Result(..), runTransaction)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use record patterns" :: String) #-}
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * Execution
|
||||
|
||||
@ -91,7 +88,7 @@ runThreads sched memtype ref = go Seq.empty [] Nothing where
|
||||
stepped <- stepThread sched memtype chosen (_continuation $ fromJust thread) $ ctx { cSchedState = g' }
|
||||
case stepped of
|
||||
(Right ctx', actOrTrc) ->
|
||||
let (act, trc) = getActAndTrc actOrTrc
|
||||
let (_, trc) = getActAndTrc actOrTrc
|
||||
threads' = if (interruptible <$> M.lookup chosen (cThreads ctx')) /= Just False
|
||||
then unblockWaitingOn chosen (cThreads ctx')
|
||||
else cThreads ctx'
|
||||
|
||||
@ -19,8 +19,6 @@ import Data.List.NonEmpty (NonEmpty, fromList)
|
||||
import Test.DejaFu.Common
|
||||
import Test.DejaFu.STM (STMLike)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use record patterns" :: String) #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * The @Conc@ Monad
|
||||
|
||||
|
||||
@ -68,30 +68,30 @@ bufferWrite (WriteBuffer wb) k@(tid, _) cref@(CRef _ ref) new = do
|
||||
(locals, count, def) <- readRef ref
|
||||
writeRef ref (M.insert tid new locals, count, def)
|
||||
|
||||
return $ WriteBuffer buffer'
|
||||
pure (WriteBuffer buffer')
|
||||
|
||||
-- | Commit the write at the head of a buffer.
|
||||
commitWrite :: MonadRef r n => WriteBuffer r -> (ThreadId, Maybe CRefId) -> n (WriteBuffer r)
|
||||
commitWrite w@(WriteBuffer wb) k = case maybe EmptyL viewl $ M.lookup k wb of
|
||||
BufferedWrite _ cref a :< rest -> do
|
||||
writeImmediate cref a
|
||||
return . WriteBuffer $ M.insert k rest wb
|
||||
pure . WriteBuffer $ M.insert k rest wb
|
||||
|
||||
EmptyL -> return w
|
||||
EmptyL -> pure w
|
||||
|
||||
-- | Read from a @CRef@, returning a newer thread-local non-committed
|
||||
-- write if there is one.
|
||||
readCRef :: MonadRef r n => CRef r a -> ThreadId -> n a
|
||||
readCRef cref tid = do
|
||||
(val, _) <- readCRefPrim cref tid
|
||||
return val
|
||||
pure val
|
||||
|
||||
-- | Read from a @CRef@, returning a @Ticket@ representing the current
|
||||
-- view of the thread.
|
||||
readForTicket :: MonadRef r n => CRef r a -> ThreadId -> n (Ticket a)
|
||||
readForTicket cref@(CRef crid _) tid = do
|
||||
(val, count) <- readCRefPrim cref tid
|
||||
return $ Ticket crid count val
|
||||
pure (Ticket crid count val)
|
||||
|
||||
-- | Perform a compare-and-swap on a @CRef@ if the ticket is still
|
||||
-- valid. This is strict in the \"new\" value argument.
|
||||
@ -103,15 +103,15 @@ casCRef cref tid (Ticket _ cc _) !new = do
|
||||
then do
|
||||
writeImmediate cref new
|
||||
tick'' <- readForTicket cref tid
|
||||
return (True, tick'')
|
||||
else return (False, tick')
|
||||
pure (True, tick'')
|
||||
else pure (False, tick')
|
||||
|
||||
-- | Read the local state of a @CRef@.
|
||||
readCRefPrim :: MonadRef r n => CRef r a -> ThreadId -> n (a, Integer)
|
||||
readCRefPrim (CRef _ ref) tid = do
|
||||
(vals, count, def) <- readRef ref
|
||||
|
||||
return (M.findWithDefault def tid vals, count)
|
||||
pure (M.findWithDefault def tid vals, count)
|
||||
|
||||
-- | Write and commit to a @CRef@ immediately, clearing the update map
|
||||
-- and incrementing the write count.
|
||||
@ -183,15 +183,15 @@ mutMVar blocking (MVar cvid ref) a c threadid threads = do
|
||||
Just _
|
||||
| blocking ->
|
||||
let threads' = block (OnMVarEmpty cvid) threadid threads
|
||||
in return (False, threads', [])
|
||||
in pure (False, threads', [])
|
||||
|
||||
| otherwise ->
|
||||
return (False, goto (c False) threadid threads, [])
|
||||
pure (False, goto (c False) threadid threads, [])
|
||||
|
||||
Nothing -> do
|
||||
writeRef ref $ Just a
|
||||
let (threads', woken) = wake (OnMVarFull cvid) threads
|
||||
return (True, goto (c True) threadid threads', woken)
|
||||
pure (True, goto (c True) threadid threads', woken)
|
||||
|
||||
-- | Read a @MVar@, in either a blocking or nonblocking
|
||||
-- way.
|
||||
@ -205,12 +205,12 @@ seeMVar emptying blocking (MVar cvid ref) c threadid threads = do
|
||||
Just _ -> do
|
||||
when emptying $ writeRef ref Nothing
|
||||
let (threads', woken) = wake (OnMVarEmpty cvid) threads
|
||||
return (True, goto (c val) threadid threads', woken)
|
||||
pure (True, goto (c val) threadid threads', woken)
|
||||
|
||||
Nothing
|
||||
| blocking ->
|
||||
let threads' = block (OnMVarFull cvid) threadid threads
|
||||
in return (False, threads', [])
|
||||
in pure (False, threads', [])
|
||||
|
||||
| otherwise ->
|
||||
return (False, goto (c Nothing) threadid threads, [])
|
||||
pure (False, goto (c Nothing) threadid threads, [])
|
||||
|
||||
@ -116,7 +116,7 @@ launch' :: MaskingState -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action
|
||||
launch' ms tid a = M.insert tid thread where
|
||||
thread = Thread { _continuation = a umask, _blocking = Nothing, _handlers = [], _masking = ms }
|
||||
|
||||
umask mb = resetMask True Unmasked >> mb >>= \b -> resetMask False ms >> return b
|
||||
umask mb = resetMask True Unmasked >> mb >>= \b -> resetMask False ms >> pure b
|
||||
resetMask typ m = cont $ \k -> AResetMask typ True m $ k ()
|
||||
|
||||
-- | Kill a thread.
|
||||
|
||||
@ -94,7 +94,6 @@ import Control.DeepSeq (NFData(..))
|
||||
import Control.Monad.Ref (MonadRef)
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import System.Random (RandomGen)
|
||||
|
||||
@ -172,7 +172,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
|
||||
-- Construct a new subtree corresponding to a trace suffix.
|
||||
subtree state tid sleep ((_, _, a):rest) =
|
||||
let state' = updateDepState state tid a
|
||||
sleep' = M.filterWithKey (\t a' -> not $ (dependent memtype) state' tid a t a') sleep
|
||||
sleep' = M.filterWithKey (\t a' -> not $ dependent memtype state' tid a t a') sleep
|
||||
in DPOR
|
||||
{ dporRunnable = S.fromList $ case rest of
|
||||
((_, runnable, _):_) -> map fst runnable
|
||||
|
||||
@ -23,8 +23,6 @@ import Data.List (nub)
|
||||
|
||||
import Test.DejaFu.Common
|
||||
|
||||
{-# ANN module ("HLint: ignore Use record patterns" :: String) #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- The @STMLike@ monad
|
||||
|
||||
@ -102,15 +100,15 @@ doTransaction ma idsource = do
|
||||
|
||||
let c = runCont ma (SStop . writeRef ref . Just . Right)
|
||||
|
||||
(idsource', undo, readen, written, trace) <- go ref c (return ()) idsource [] [] []
|
||||
(idsource', undo, readen, written, trace) <- go ref c (pure ()) idsource [] [] []
|
||||
|
||||
res <- readRef ref
|
||||
|
||||
case res of
|
||||
Just (Right val) -> return (Success (nub readen) (nub written) val, undo, idsource', reverse trace)
|
||||
Just (Right val) -> pure (Success (nub readen) (nub written) val, undo, idsource', reverse trace)
|
||||
|
||||
Just (Left exc) -> undo >> return (Exception exc, return (), idsource, reverse trace)
|
||||
Nothing -> undo >> return (Retry $ nub readen, return (), idsource, reverse trace)
|
||||
Just (Left exc) -> undo >> pure (Exception exc, pure (), idsource, reverse trace)
|
||||
Nothing -> undo >> pure (Retry $ nub readen, pure (), idsource, reverse trace)
|
||||
|
||||
where
|
||||
go ref act undo nidsrc readen written sofar = do
|
||||
@ -124,11 +122,13 @@ doTransaction ma idsource = do
|
||||
newSofar = tact : sofar
|
||||
|
||||
case tact of
|
||||
TStop -> return (newIDSource, newUndo, newReaden, newWritten, TStop:newSofar)
|
||||
TRetry -> writeRef ref Nothing
|
||||
>> return (newIDSource, newUndo, newReaden, newWritten, TRetry:newSofar)
|
||||
TThrow -> writeRef ref (Just . Left $ case act of SThrow e -> toException e; _ -> undefined)
|
||||
>> return (newIDSource, newUndo, newReaden, newWritten, TThrow:newSofar)
|
||||
TStop -> pure (newIDSource, newUndo, newReaden, newWritten, TStop:newSofar)
|
||||
TRetry -> do
|
||||
writeRef ref Nothing
|
||||
pure (newIDSource, newUndo, newReaden, newWritten, TRetry:newSofar)
|
||||
TThrow -> do
|
||||
writeRef ref (Just . Left $ case act of SThrow e -> toException e; _ -> undefined)
|
||||
pure (newIDSource, newUndo, newReaden, newWritten, TThrow:newSofar)
|
||||
_ -> go ref newAct newUndo newIDSource newReaden newWritten newSofar
|
||||
|
||||
-- | Run a transaction for one step.
|
||||
@ -141,50 +141,50 @@ stepTrans act idsource = case act of
|
||||
SOrElse a b c -> stepOrElse a b c
|
||||
SStop na -> stepStop na
|
||||
|
||||
SThrow e -> return (SThrow e, nothing, idsource, [], [], TThrow)
|
||||
SRetry -> return (SRetry, nothing, idsource, [], [], TRetry)
|
||||
SThrow e -> pure (SThrow e, nothing, idsource, [], [], TThrow)
|
||||
SRetry -> pure (SRetry, nothing, idsource, [], [], TRetry)
|
||||
|
||||
where
|
||||
nothing = return ()
|
||||
nothing = pure ()
|
||||
|
||||
stepCatch h stm c = cases TCatch stm c
|
||||
(\trace -> return (SRetry, nothing, idsource, [], [], TCatch trace Nothing))
|
||||
(\trace -> pure (SRetry, nothing, idsource, [], [], TCatch trace Nothing))
|
||||
(\trace exc -> case fromException exc of
|
||||
Just exc' -> transaction (TCatch trace . Just) (h exc') c
|
||||
Nothing -> return (SThrow exc, nothing, idsource, [], [], TCatch trace Nothing))
|
||||
Nothing -> pure (SThrow exc, nothing, idsource, [], [], TCatch trace Nothing))
|
||||
|
||||
stepRead (TVar (tvid, ref)) c = do
|
||||
val <- readRef ref
|
||||
return (c val, nothing, idsource, [tvid], [], TRead tvid)
|
||||
pure (c val, nothing, idsource, [tvid], [], TRead tvid)
|
||||
|
||||
stepWrite (TVar (tvid, ref)) a c = do
|
||||
old <- readRef ref
|
||||
writeRef ref a
|
||||
return (c, writeRef ref old, idsource, [], [tvid], TWrite tvid)
|
||||
pure (c, writeRef ref old, idsource, [], [tvid], TWrite tvid)
|
||||
|
||||
stepNew n a c = do
|
||||
let (idsource', tvid) = nextTVId n idsource
|
||||
ref <- newRef a
|
||||
let tvar = TVar (tvid, ref)
|
||||
return (c tvar, nothing, idsource', [], [tvid], TNew)
|
||||
pure (c tvar, nothing, idsource', [], [tvid], TNew)
|
||||
|
||||
stepOrElse a b c = cases TOrElse a c
|
||||
(\trace -> transaction (TOrElse trace . Just) b c)
|
||||
(\trace exc -> return (SThrow exc, nothing, idsource, [], [], TOrElse trace Nothing))
|
||||
(\trace exc -> pure (SThrow exc, nothing, idsource, [], [], TOrElse trace Nothing))
|
||||
|
||||
stepStop na = do
|
||||
na
|
||||
return (SStop na, nothing, idsource, [], [], TStop)
|
||||
pure (SStop na, nothing, idsource, [], [], TStop)
|
||||
|
||||
cases tact stm onSuccess onRetry onException = do
|
||||
(res, undo, idsource', trace) <- doTransaction stm idsource
|
||||
case res of
|
||||
Success readen written val -> return (onSuccess val, undo, idsource', readen, written, tact trace Nothing)
|
||||
Success readen written val -> pure (onSuccess val, undo, idsource', readen, written, tact trace Nothing)
|
||||
Retry readen -> do
|
||||
(res', undo', idsource'', readen', written', trace') <- onRetry trace
|
||||
pure (res', undo', idsource'', readen ++ readen', written', trace')
|
||||
Exception exc -> onException trace exc
|
||||
|
||||
transaction tact stm onSuccess = cases (\t _ -> tact t) stm onSuccess
|
||||
(\trace -> return (SRetry, nothing, idsource, [], [], tact trace))
|
||||
(\trace exc -> return (SThrow exc, nothing, idsource, [], [], tact trace))
|
||||
(\trace -> pure (SRetry, nothing, idsource, [], [], tact trace))
|
||||
(\trace exc -> pure (SThrow exc, nothing, idsource, [], [], tact trace))
|
||||
|
||||
@ -107,7 +107,7 @@ instance Assertable (Conc.ConcIO ()) where
|
||||
|
||||
assertableP :: Predicate (Either HUnitFailure ())
|
||||
assertableP = alwaysTrue $ \r -> case r of
|
||||
Right (Left (HUnitFailure {})) -> False
|
||||
Right (Left HUnitFailure {}) -> False
|
||||
_ -> True
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@ -262,19 +262,19 @@ data ConcIOTest where
|
||||
deriving Typeable
|
||||
|
||||
instance IsTest ConcTest where
|
||||
testOptions = return []
|
||||
testOptions = pure []
|
||||
|
||||
run _ (ConcTest traces p) _ =
|
||||
let err = showErr $ p traces
|
||||
in return $ if null err then testPassed "" else testFailed err
|
||||
in pure (if null err then testPassed "" else testFailed err)
|
||||
|
||||
instance IsTest ConcIOTest where
|
||||
testOptions = return []
|
||||
testOptions = pure []
|
||||
|
||||
run _ (ConcIOTest iotraces p) _ = do
|
||||
traces <- iotraces
|
||||
let err = showErr $ p traces
|
||||
return $ if null err then testPassed "" else testFailed err
|
||||
pure (if null err then testPassed "" else testFailed err)
|
||||
|
||||
-- | Produce a Tasty 'TestTree' from a Deja Fu test.
|
||||
testst :: (Show a, RandomGen g)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user