From 9f5b04eb6362cc9bee7a5a0dc945ab4e00554a8e Mon Sep 17 00:00:00 2001
From: Michael Walker <mike@barrucadu.co.uk>
Date: Tue, 23 Dec 2014 15:20:11 +0000
Subject: [PATCH] Add a little test framework, and a test case

---
 Tests.hs         | 18 ++++++++++++++++++
 Tests/Cases.hs   | 27 +++++++++++++++++++++++++++
 Tests/Utils.hs   | 43 +++++++++++++++++++++++++++++++++++++++++++
 monad-conc.cabal | 13 ++++++++++++-
 4 files changed, 100 insertions(+), 1 deletion(-)
 create mode 100644 Tests.hs
 create mode 100644 Tests/Cases.hs
 create mode 100644 Tests/Utils.hs

diff --git a/Tests.hs b/Tests.hs
new file mode 100644
index 0000000..ce277b4
--- /dev/null
+++ b/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
diff --git a/Tests/Cases.hs b/Tests/Cases.hs
new file mode 100644
index 0000000..ce7b18d
--- /dev/null
+++ b/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
diff --git a/Tests/Utils.hs b/Tests/Utils.hs
new file mode 100644
index 0000000..0f74845
--- /dev/null
+++ b/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
diff --git a/monad-conc.cabal b/monad-conc.cabal
index 4f1f051..b063ff1 100755
--- a/monad-conc.cabal
+++ b/monad-conc.cabal
@@ -30,4 +30,15 @@ library
                      , transformers
   -- hs-source-dirs:      
   default-language:    Haskell2010
-  ghc-options:         -Wall
\ No newline at end of file
+  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