Add dining philosophers tests

Tests.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+import Control.Monad (when)
 import Tests.Cases
 import Tests.Utils
 import System.Exit (exitFailure, exitSuccess)
@@ -13,6 +14,6 @@ runTest :: Bool -> Test -> IO Bool
 runTest verbose (Test {name = name, result = result}) = do
   res <- result
   case res of
-    Pass      -> (if verbose then putStrLn ("\27[32m[pass]\27[0m " ++ name) else return ()) >> return True
+    Pass      -> when verbose (putStrLn $ "\27[32m[pass]\27[0m " ++ name)  >> return True
     Fail str  -> putStrLn ("\27[31m[fail]\27[0m "  ++ name ++ ": " ++ str) >> return False
     Error str -> putStrLn ("\27[35m[error]\27[0m " ++ name ++ ": " ++ str) >> return False

Tests/Cases.hs

@@ -1,5 +1,6 @@
 module Tests.Cases where
 
+import Control.Monad (replicateM)
 import Control.Monad.Conc.Class
 import Control.Monad.Conc.CVar
 import Tests.Utils
@@ -8,6 +9,13 @@ import Tests.Utils
 testCases :: [Test]
 testCases =
   [ Test "Simple 2-Deadlock" $ testNot "No deadlocks found!" $ testDeadlockFree 100 simple2Deadlock
+  , Test "2 Philosophers"    $ testNot "No deadlocks found!" $ testDeadlockFree 100 $ philosophers 2
+  , Test "3 Philosophers"    $ testNot "No deadlocks found!" $ testDeadlockFree 100 $ philosophers 3
+  --Random scheduling isn't good enough for these, without increasing
+  --the runs.
+  --, Test "4 Philosophers"    $ testNot "No deadlocks found!" $ testDeadlockFree 100 $ philosophers 4
+  --, Test "5 Philosophers"    $ testNot "No deadlocks found!" $ testDeadlockFree 100 $ philosophers 5
+  --, Test "100 Philosophers"  $ testNot "No deadlocks found!" $ testDeadlockFree 100 $ philosophers 100
   ]
 
 -- | Should deadlock on a minority of schedules.
@@ -25,3 +33,25 @@ simple2Deadlock = do
   takeCVar j2
 
   takeCVar c
+
+-- | Dining philosophers problem, result is irrelevent, we just want
+-- deadlocks.
+philosophers :: ConcCVar cvar m => Int -> m ()
+philosophers n = do
+  forks <- replicateM n newEmptyCVar
+  let phils = map (\(i,p) -> p i forks) $ zip [0..] $ replicate n philosopher
+  cvars <- mapM spawn phils
+  mapM_ takeCVar cvars
+
+  where
+    philosopher ident forks = do
+      let leftId  = ident
+      let rightId = (ident + 1) `mod` length forks
+      lock $ forks !! leftId
+      lock $ forks !! rightId
+      -- In the traditional approach, we'd wait for a random time
+      -- here, but we want the only source of (important)
+      -- nondeterminism to come from the scheduler, which it does, as
+      -- pre-emption is effectively a delay.
+      unlock $ forks !! leftId
+      unlock $ forks !! rightId