From 7e6fcd4a395cb3d6f130492d5ae09e21fbe807f5 Mon Sep 17 00:00:00 2001
From: Michael Walker <mike@barrucadu.co.uk>
Date: Sat, 27 Dec 2014 12:26:40 +0000
Subject: [PATCH] Swap main Fixed implementation from IO to ST.

---
 Control/Monad/Conc/Fixed.hs |  4 ++--
 Control/Monad/Conc/SCT.hs   | 16 ++++++++--------
 Tests.hs                    |  5 ++---
 Tests/Utils.hs              | 25 ++++++++++---------------
 monad-conc.cabal            |  1 +
 5 files changed, 23 insertions(+), 28 deletions(-)

diff --git a/Control/Monad/Conc/Fixed.hs b/Control/Monad/Conc/Fixed.hs
index e92ff53..144947c 100755
--- a/Control/Monad/Conc/Fixed.hs
+++ b/Control/Monad/Conc/Fixed.hs
@@ -1,8 +1,8 @@
 -- | Concurrent monads with a fixed scheduler.
 module Control.Monad.Conc.Fixed
-  ( module Control.Monad.Conc.Fixed.IO
+  ( module Control.Monad.Conc.Fixed.ST
   , module Control.Monad.Conc.Fixed.Schedulers
   ) where
 
-import Control.Monad.Conc.Fixed.IO
+import Control.Monad.Conc.Fixed.ST
 import Control.Monad.Conc.Fixed.Schedulers
diff --git a/Control/Monad/Conc/SCT.hs b/Control/Monad/Conc/SCT.hs
index f0cde2a..85450df 100644
--- a/Control/Monad/Conc/SCT.hs
+++ b/Control/Monad/Conc/SCT.hs
@@ -83,15 +83,15 @@ data Decision =
 -- The initial state for each run is the final state of the last run,
 -- so it is important that the scheduler actually maintain some
 -- internal state, or all the results will be identical.
-runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, SCTTrace)]
-runSCT _     _ 0 _ = return []
-runSCT sched s n c = do
-  (res, (s', strace), ttrace) <- runConc' sched (s, [(Start 0, [])]) c
-  rest <- runSCT sched s' (n - 1) c
-  return $ (res, zipWith mktrace strace ttrace) : rest
+runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> [(Maybe a, SCTTrace)]
+runSCT _     _ 0 _ = []
+runSCT sched s n c = (res, zipWith mktrace strace ttrace) : rest where
 
-  where
-    mktrace (d, alts) (_, act) = (d, alts, act)
+  (res, (s', strace), ttrace) = runConc' sched (s, [(Start 0, [])]) c
+
+  rest = runSCT sched s' (n - 1) c
+
+  mktrace (d, alts) (_, act) = (d, alts, act)
 
 -- | A simple pre-emptive random scheduler.
 sctRandom :: RandomGen g => SCTScheduler g
diff --git a/Tests.hs b/Tests.hs
index 379c74f..b890068 100644
--- a/Tests.hs
+++ b/Tests.hs
@@ -11,9 +11,8 @@ main = do
   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
+runTest verbose (Test {name = name, result = result}) =
+  case result of
     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
diff --git a/Tests/Utils.hs b/Tests/Utils.hs
index 98dc575..08dab42 100644
--- a/Tests/Utils.hs
+++ b/Tests/Utils.hs
@@ -1,7 +1,6 @@
 {-# 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)
@@ -9,23 +8,23 @@ import Data.Maybe (isJust, 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 Test   = Test { name :: String, result :: Result }
 data Result = Pass | Fail String | Error String
 
 -- | Test that a predicate holds over the results of a concurrent
 -- computation.
-testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> IO Result
-testPred predicate num conc = predicate . map fst <$> runSCT sctRandom (mkStdGen 0) num conc
+testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> Result
+testPred 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 :: Int -> (forall t. Conc t a) -> Result
 testDeadlockFree = testPred 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 deadlocks.
-testDeadlocks :: Int -> (forall t. Conc t a) -> IO Result
+testDeadlocks :: Int -> (forall t. Conc t a) -> Result
 testDeadlocks = testPred predicate where
   predicate xs = case filter isJust xs of
     [] -> Pass
@@ -33,7 +32,7 @@ testDeadlocks = testPred predicate where
 
 -- | Test that a concurrent computation always returns the same
 -- result.
-testAlwaysSame :: (Eq a, Ord a) => Int -> (forall t. Conc t a) -> IO Result
+testAlwaysSame :: (Eq a, Ord a) => Int -> (forall t. Conc t a) -> Result
 testAlwaysSame = testPred predicate where
   predicate xs = case group $ sort xs of
     []    -> Pass
@@ -41,11 +40,7 @@ testAlwaysSame = testPred predicate where
     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
+testNot :: String -> Result -> Result
+testNot err  Pass    = Fail err
+testNot _   (Fail _) = Pass
+testNot _    err     = err
diff --git a/monad-conc.cabal b/monad-conc.cabal
index 9688d17..f178212 100755
--- a/monad-conc.cabal
+++ b/monad-conc.cabal
@@ -42,6 +42,7 @@ test-suite tests
   build-depends:         monad-conc
                        , base
                        , containers
+                       , monad-st
                        , mtl
                        , random
                        , transformers