Add racey logger example and tests

tests/Tests/Cases.hs

@@ -6,6 +6,8 @@ import Control.Monad.Conc.Class
 import Control.Monad.Conc.CVar
 import Control.Monad.Conc.SCT.Tests
 
+import qualified Tests.Logger as L
+
 data Test = Test { name :: String, result :: Result }
 
 -- | List of all tests
@@ -15,12 +17,13 @@ testCases =
   , Test "2 Philosophers"    $ runTest deadlocksSometimes $ philosophers 2
   , Test "3 Philosophers"    $ runTest deadlocksSometimes $ philosophers 3
   , Test "4 Philosophers"    $ runTest deadlocksSometimes $ philosophers 4
-  , Test "25 Philosophers"   $ runTest deadlocksSometimes $ philosophers 25
-  , Test "100 Philosophers"  $ runTest deadlocksSometimes $ philosophers 100
   , Test "Threshold Value"   $ runTest (pNot alwaysSame)    thresholdValue
   , Test "Forgotten Unlock"  $ runTest deadlocksAlways      forgottenUnlock
   , Test "Simple 2-Race"     $ runTest (pNot alwaysSame)    simple2Race
   , Test "Racey Stack"       $ runTest (pNot alwaysSame)    raceyStack
+  , Test "Logger (LA)"       $ L.testLA
+  , Test "Logger (LP)"       $ L.testLP
+  , Test "Logger (LE)"       $ L.testLE
   ]
 
 -- | Should deadlock on a minority of schedules.

tests/Tests/Logger.hs

@@ -0,0 +1,80 @@
+-- Modification (to introduce bug) of an example in Parallel and
+-- Concurrent Programming in Haskell, chapter 7.
+module Tests.Logger
+  ( Logger
+  , initLogger
+  , logMessage
+  , logStop
+  , bad
+  , testLA, testLP, testLE
+  ) where
+
+import Control.Monad.Conc.Class
+import Control.Monad.Conc.CVar
+import Control.Monad.Conc.SCT.Tests
+
+data Logger cvar = Logger (cvar LogCommand) (cvar [String])
+
+data LogCommand = Message String | Stop
+
+-- | Create a new logger with no internal log.
+initLogger :: ConcCVar cvar m => m (Logger cvar)
+initLogger = do
+  cmd <- newEmptyCVar
+  log <- newCVar []
+  let l = Logger cmd log
+  fork $ logger l
+  return l
+
+logger :: ConcCVar cvar m => Logger cvar -> 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 :: ConcCVar cvar m => Logger cvar -> String -> m ()
+logMessage (Logger cmd _) str = putCVar cmd $ Message str
+
+-- | Stop the logger and return the contents of the log.
+logStop :: ConcCVar cvar m => Logger cvar -> m [String]
+logStop (Logger cmd log) = do
+  putCVar cmd Stop
+  readCVar log
+
+-- | Race condition! Can you see where?
+bad :: ConcCVar cvar m => m [String]
+bad = 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.
+testLA :: Result
+testLA = runTest (alwaysTrue listContents) bad where
+  listContents (Just strs) = strs `elem` [ ["Hello", "World", "Foo", "Bar", "Baz"]
+                                         , ["Hello", "World", "Foo", "Bar"]
+                                         ]
+  listContents Nothing = False
+
+-- | Test that the "proper" result occurs at least once.
+testLP :: Result
+testLP = runTest (somewhereTrue loggedAll) bad where
+  loggedAll (Just a) = length a == 5
+  loggedAll Nothing  = False
+
+-- | Test that the erroneous result occurs at least once.
+testLE :: Result
+testLE = runTest (somewhereTrue loggedAlmostAll) bad where
+  loggedAlmostAll (Just a) = length a == 4
+  loggedAlmostAll Nothing  = False