Add a little test framework, and a test case

Tests.hs

@@ -0,0 +1,18 @@
+module Main (main) where
+
+import Tests.Cases
+import Tests.Utils
+import System.Exit (exitFailure, exitSuccess)
+
+main :: IO ()
+main = do
+  results <- mapM (runTest True) testCases
+  if and results then exitSuccess else exitFailure
+
+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
+    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

@@ -0,0 +1,27 @@
+module Tests.Cases where
+
+import Control.Monad.Conc.Class
+import Control.Monad.Conc.CVar
+import Tests.Utils
+
+-- | List of all tests
+testCases :: [Test]
+testCases =
+  [ Test "Simple 2-Deadlock" $ testNot "No deadlocks found!" $ testDeadlockFree 100 simple2Deadlock
+  ]
+
+-- | Should deadlock on a minority of schedules.
+simple2Deadlock :: ConcCVar cvar m => m Int
+simple2Deadlock = do
+  a <- newEmptyCVar
+  b <- newEmptyCVar
+
+  c <- newCVar 0
+
+  j1 <- spawn $ lock a >> lock b >> modifyCVar_ c (return . succ) >> unlock b >> unlock a
+  j2 <- spawn $ lock b >> lock a >> modifyCVar_ c (return . pred) >> unlock a >> unlock b
+
+  takeCVar j1
+  takeCVar j2
+
+  takeCVar c

Tests/Utils.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE RankNTypes #-}
+module Tests.Utils where
+
+import Control.Applicative ((<$>))
+import Control.Monad.Conc.Fixed (Conc)
+import Control.Monad.Conc.SCT (runSCT, sctRandom)
+import Data.List (group, sort)
+import Data.Maybe (isNothing)
+import System.Random (mkStdGen)
+
+-- Couldn't get Cabal's detailed tests to work, hence this approach.
+data Test   = Test { name :: String, result :: IO Result }
+data Result = Pass | Fail String | Error String
+
+-- | Run a concurrent computation, aggregating the results.
+doTest :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> IO Result
+doTest predicate num conc = predicate <$> map fst <$> runSCT sctRandom (mkStdGen 0) num conc
+
+-- | Test that a concurrent computation is free of deadlocks.
+testDeadlockFree :: Int -> (forall t. Conc t a) -> IO Result
+testDeadlockFree = doTest predicate where
+  predicate xs = case filter isNothing xs of
+    [] -> Pass
+    ds -> Fail $ "Found " ++ show (length ds) ++ "/" ++ show (length xs) ++ " deadlocking schedules."
+
+-- | Test that a concurrent computation always returns the same
+-- result.
+testAlwaysSame :: (Eq a, Ord a) => Int -> (forall t. Conc t a) -> IO Result
+testAlwaysSame = doTest predicate where
+  predicate xs = case group $ sort xs of
+    []    -> Pass
+    [[_]] -> Pass
+    [gs]  -> Fail $ "Found " ++ show (length gs) ++ " distinct results."
+
+-- | Invert the result of a test.
+testNot :: String -> IO Result -> IO Result
+testNot err old = do
+  res <- old
+  return $
+    case res of
+      Pass   -> Fail err
+      Fail _ -> Pass
+      e -> e

monad-conc.cabal

@@ -31,3 +31,14 @@ library
   -- hs-source-dirs:      
   default-language:    Haskell2010
   ghc-options:         -Wall
+
+test-suite tests
+  type:                exitcode-stdio-1.0
+  main-is:             Tests.hs
+  build-depends:         monad-conc
+                       , base
+                       , containers
+                       , mtl
+                       , random
+                       , transformers
+  default-language:    Haskell2010