mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-20 12:01:33 +03:00
77 lines
2.1 KiB
Haskell
Executable File
77 lines
2.1 KiB
Haskell
Executable File
-- Modification (to introduce bug) of an example in Parallel and
|
|
-- Concurrent Programming in Haskell, chapter 7.
|
|
module Tests.Logger
|
|
( badLogger
|
|
, validResult, isGood, isBad
|
|
) where
|
|
|
|
import Control.Concurrent.CVar
|
|
import Control.Monad.Conc.Class
|
|
import Test.DejaFu
|
|
|
|
data Logger m = Logger (CVar m LogCommand) (CVar m [String])
|
|
|
|
data LogCommand = Message String | Stop
|
|
|
|
-- | Create a new logger with no internal log.
|
|
initLogger :: MonadConc m => m (Logger m)
|
|
initLogger = do
|
|
cmd <- newEmptyCVar
|
|
log <- newCVar []
|
|
let l = Logger cmd log
|
|
fork $ logger l
|
|
return l
|
|
|
|
logger :: MonadConc m => Logger m -> m ()
|
|
logger (Logger cmd log) = loop where
|
|
loop = do
|
|
command <- takeCVar cmd
|
|
case command of
|
|
Message str -> do
|
|
strs <- takeCVar log
|
|
putCVar log (strs ++ [str])
|
|
loop
|
|
Stop -> return ()
|
|
|
|
-- | Add a string to the log.
|
|
logMessage :: MonadConc m => Logger m -> String -> m ()
|
|
logMessage (Logger cmd _) str = putCVar cmd $ Message str
|
|
|
|
-- | Stop the logger and return the contents of the log.
|
|
logStop :: MonadConc m => Logger m -> m [String]
|
|
logStop (Logger cmd log) = do
|
|
putCVar cmd Stop
|
|
readCVar log
|
|
|
|
-- | Race condition! Can you see where?
|
|
badLogger :: MonadConc m => m [String]
|
|
badLogger = do
|
|
l <- initLogger
|
|
logMessage l "Hello"
|
|
logMessage l "World"
|
|
logMessage l "Foo"
|
|
logMessage l "Bar"
|
|
logMessage l "Baz"
|
|
logStop l
|
|
|
|
-- | Test that the result is always in the set of allowed values, and
|
|
-- doesn't deadlock.
|
|
validResult :: Predicate [String]
|
|
validResult = alwaysTrue check where
|
|
check (Just strs) = strs `elem` [ ["Hello", "World", "Foo", "Bar", "Baz"]
|
|
, ["Hello", "World", "Foo", "Bar"]
|
|
]
|
|
check Nothing = False
|
|
|
|
-- | Test that the "proper" result occurs at least once.
|
|
isGood :: Predicate [String]
|
|
isGood = somewhereTrue check where
|
|
check (Just a) = length a == 5
|
|
check Nothing = False
|
|
|
|
-- | Test that the erroneous result occurs at least once.
|
|
isBad :: Predicate [String]
|
|
isBad = somewhereTrue check where
|
|
check (Just a) = length a == 4
|
|
check Nothing = False
|