From d8ab5ee9e38766a7777a68ba6352f3927cf1baeb Mon Sep 17 00:00:00 2001 From: Laurent Rene de Cotret Date: Tue, 29 Oct 2024 20:50:41 -0400 Subject: [PATCH] Remove all dependencies on `rematch` --- .../distributed-process-async.cabal | 1 - .../distributed-process-client-server.cabal | 2 - .../tests/TestManagedProcess.hs | 3 +- .../distributed-process-execution.cabal | 2 - .../tests/TestExchange.hs | 46 +++++---- .../tests/TestMailbox.hs | 11 +-- .../distributed-process-extras.cabal | 4 - .../tests/TestLog.hs | 4 +- .../tests/TestPrimitives.hs | 11 +-- .../tests/TestQueues.hs | 20 ++-- .../tests/TestTimer.hs | 1 - .../distributed-process-supervisor.cabal | 2 - .../tests/TestSupervisor.hs | 98 +++++++++---------- .../tests/TestUtils.hs | 33 +------ .../distributed-process-systest.cabal | 1 - .../Distributed/Process/SysTest/Utils.hs | 27 +---- stack-ghc-8.10.7.yaml | 3 +- stack-ghc-9.0.2.yaml | 3 +- stack-ghc-9.2.7.yaml | 2 - stack-ghc-9.4.5.yaml | 2 - stack-ghc-9.8.2.yaml | 2 - 21 files changed, 95 insertions(+), 183 deletions(-) diff --git a/packages/distributed-process-async/distributed-process-async.cabal b/packages/distributed-process-async/distributed-process-async.cabal index 8d683dd9..f397f9a5 100644 --- a/packages/distributed-process-async/distributed-process-async.cabal +++ b/packages/distributed-process-async/distributed-process-async.cabal @@ -79,7 +79,6 @@ test-suite AsyncTests stm >= 2.3 && < 2.6, test-framework >= 0.6 && < 0.9, test-framework-hunit, - rematch >= 0.2.0.0, transformers hs-source-dirs: tests diff --git a/packages/distributed-process-client-server/distributed-process-client-server.cabal b/packages/distributed-process-client-server/distributed-process-client-server.cabal index ee3323dc..7133d3ec 100644 --- a/packages/distributed-process-client-server/distributed-process-client-server.cabal +++ b/packages/distributed-process-client-server/distributed-process-client-server.cabal @@ -92,7 +92,6 @@ test-suite ManagedProcessTests test-framework >= 0.6 && < 0.9, test-framework-hunit, transformers, - rematch >= 0.2.0.0, ghc-prim, exceptions other-modules: Counter, @@ -131,7 +130,6 @@ test-suite PrioritisedProcessTests test-framework, test-framework-hunit, transformers, - rematch, ghc-prim, exceptions other-modules: ManagedProcessCommon, diff --git a/packages/distributed-process-client-server/tests/TestManagedProcess.hs b/packages/distributed-process-client-server/tests/TestManagedProcess.hs index 09fa3ff5..45b2dbd1 100644 --- a/packages/distributed-process-client-server/tests/TestManagedProcess.hs +++ b/packages/distributed-process-client-server/tests/TestManagedProcess.hs @@ -20,6 +20,7 @@ import Control.Distributed.Process.ManagedProcess import Control.Distributed.Process.SysTest.Utils import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Serializable() +import Control.Monad (replicateM_) import MathsDemo import Counter @@ -197,7 +198,7 @@ testCounterExceedsLimit result = do mref <- monitor pid -- exceed the limit - 9 `times` (void $ incCount pid) + 9 `replicateM_` (void $ incCount pid) -- this time we should fail _ <- (incCount pid) diff --git a/packages/distributed-process-execution/distributed-process-execution.cabal b/packages/distributed-process-execution/distributed-process-execution.cabal index 2937702d..80c8f24e 100644 --- a/packages/distributed-process-execution/distributed-process-execution.cabal +++ b/packages/distributed-process-execution/distributed-process-execution.cabal @@ -98,7 +98,6 @@ test-suite ExchangeTests QuickCheck >= 2.4, test-framework-quickcheck2, transformers, - rematch >= 0.2.0.0, ghc-prim hs-source-dirs: tests @@ -139,7 +138,6 @@ test-suite MailboxTests QuickCheck >= 2.4, test-framework-quickcheck2, transformers, - rematch >= 0.2.0.0, ghc-prim hs-source-dirs: tests diff --git a/packages/distributed-process-execution/tests/TestExchange.hs b/packages/distributed-process-execution/tests/TestExchange.hs index 088753af..6ccae812 100644 --- a/packages/distributed-process-execution/tests/TestExchange.hs +++ b/packages/distributed-process-execution/tests/TestExchange.hs @@ -18,13 +18,13 @@ import qualified Control.Distributed.Process.Execution.EventManager as EventMana ) import Control.Distributed.Process.SysTest.Utils import Control.Monad (void, forM, forever) -import Control.Rematch (equalTo) import Prelude hiding (drop) import Network.Transport.TCP import qualified Network.Transport as NT import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit +import Test.HUnit (assertEqual, assertBool) testKeyBasedRouting :: TestResult Bool -> Process () testKeyBasedRouting result = do @@ -67,20 +67,22 @@ testMultipleRoutes result = do received <- forM (replicate (2 * 3) us) (const $ receiveChanTimeout 1000 rp) -- all bindings for 'abc' fired correctly - received `shouldContain` Just (p1, Left "Hello") - received `shouldContain` Just (p3, Left "Hello") - received `shouldContain` Just (p1, Right (123 :: Int)) - received `shouldContain` Just (p3, Right (123 :: Int)) - - -- however the bindings for 'def' never fired - received `shouldContain` Nothing - received `shouldNotContain` Just (p2, Left "Hello") - received `shouldNotContain` Just (p2, Right (123 :: Int)) - - -- none of the bindings should have examined the headers! - received `shouldNotContain` Just (p1, Left "Goodbye") - received `shouldNotContain` Just (p2, Left "Goodbye") - received `shouldNotContain` Just (p3, Left "Goodbye") + liftIO $ do + + assertBool mempty $ Just (p1, Left "Hello") `elem` received + assertBool mempty $ Just (p3, Left "Hello") `elem` received + assertBool mempty $ Just (p1, Right (123 :: Int)) `elem` received + assertBool mempty $ Just (p3, Right (123 :: Int)) `elem` received + + -- however the bindings for 'def' never fired + assertBool mempty $ Nothing `elem` received + assertBool mempty $ Just (p2, Left "Hello") `notElem` received + assertBool mempty $ Just (p2, Right (123 :: Int)) `notElem` received + + -- none of the bindings should have examined the headers! + assertBool mempty $ Just (p1, Left "Goodbye") `notElem` received + assertBool mempty $ Just (p2, Left "Goodbye") `notElem` received + assertBool mempty $ Just (p3, Left "Goodbye") `notElem` received testHeaderBasedRouting :: TestResult () -> Process () testHeaderBasedRouting result = do @@ -110,14 +112,16 @@ testHeaderBasedRouting result = do received <- forM (replicate 5 us) (const $ receiveChanTimeout 1000 rp) -- all bindings fired correctly - received `shouldContain` Just (p1, Left "Hello") - received `shouldContain` Just (p1, Right (123 :: Int)) - received `shouldContain` Just (p2, Right (456 :: Int)) - received `shouldContain` Just (p2, Right (789 :: Int)) - received `shouldContain` Nothing + liftIO $ do + assertBool mempty $ Just (p1, Left "Hello") `elem` received + assertBool mempty $ Just (p1, Left "Hello") `elem` received + assertBool mempty $ Just (p1, Right (123 :: Int)) `elem` received + assertBool mempty $ Just (p2, Right (456 :: Int)) `elem` received + assertBool mempty $ Just (p2, Right (789 :: Int)) `elem` received + assertBool mempty $ Nothing `elem` received -- simple check that no other bindings have fired - length received `shouldBe` equalTo (5 :: Int) + liftIO $ assertEqual mempty 5 (length received) testSimpleEventHandling :: TestResult Bool -> Process () testSimpleEventHandling result = do diff --git a/packages/distributed-process-execution/tests/TestMailbox.hs b/packages/distributed-process-execution/tests/TestMailbox.hs index e0d25989..392585d4 100644 --- a/packages/distributed-process-execution/tests/TestMailbox.hs +++ b/packages/distributed-process-execution/tests/TestMailbox.hs @@ -13,15 +13,13 @@ import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Distributed.Process.SysTest.Utils - -import Control.Rematch (equalTo) - import Prelude hiding (drop) import Data.Maybe (catMaybes) import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit +import Test.HUnit (assertEqual) import qualified MailboxTestFilters (__remoteTable) import MailboxTestFilters (myFilter, intFilter) @@ -77,9 +75,10 @@ bufferLimiting buffT result = do MailboxStats{ pendingMessages = pending' , droppedMessages = dropped' , currentLimit = limit' } <- statistics mbox - pending' `shouldBe` equalTo 4 - dropped' `shouldBe` equalTo 3 - limit' `shouldBe` equalTo 4 + liftIO $ do + assertEqual mempty 4 pending' + assertEqual mempty 3 dropped' + assertEqual mempty 4 limit' active mbox acceptEverything Just Delivery{ messages = recvd diff --git a/packages/distributed-process-extras/distributed-process-extras.cabal b/packages/distributed-process-extras/distributed-process-extras.cabal index d4bb7ae9..956747cc 100644 --- a/packages/distributed-process-extras/distributed-process-extras.cabal +++ b/packages/distributed-process-extras/distributed-process-extras.cabal @@ -81,7 +81,6 @@ test-suite InternalQueueTests test-framework-hunit, QuickCheck >= 2.4, test-framework-quickcheck2, - rematch >= 0.2.0.0, ghc-prim hs-source-dirs: tests ghc-options: -rtsopts @@ -110,7 +109,6 @@ test-suite PrimitivesTests stm, test-framework >= 0.6 && < 0.9, test-framework-hunit, - rematch >= 0.2.0.0, transformers hs-source-dirs: tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind @@ -135,7 +133,6 @@ test-suite TimerTests test-framework-hunit, QuickCheck >= 2.4, test-framework-quickcheck2, - rematch >= 0.2.0.0, ghc-prim hs-source-dirs: tests ghc-options: -rtsopts @@ -172,7 +169,6 @@ test-suite LoggerTests test-framework >= 0.6 && < 0.9, test-framework-hunit, transformers, - rematch >= 0.2.0.0, ghc-prim hs-source-dirs: tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind diff --git a/packages/distributed-process-extras/tests/TestLog.hs b/packages/distributed-process-extras/tests/TestLog.hs index 94f5385f..71df258a 100644 --- a/packages/distributed-process-extras/tests/TestLog.hs +++ b/packages/distributed-process-extras/tests/TestLog.hs @@ -4,7 +4,6 @@ module Main where --- import Control.Exception (SomeException) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan @@ -12,7 +11,7 @@ import Control.Distributed.Process hiding (monitor) import Control.Distributed.Process.Closure (remotable, mkStaticClosure) import Control.Distributed.Process.Node import Control.Distributed.Process.Extras hiding (__remoteTable) -import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger, error) +import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger) import Control.Distributed.Process.Extras.SystemLog hiding (Logger, error) import Control.Distributed.Process.SysTest.Utils import Control.Distributed.Process.Extras.Time @@ -31,7 +30,6 @@ import GHC.Read import Text.ParserCombinators.ReadP as P import Text.ParserCombinators.ReadPrec -import qualified Network.Transport as NT logLevelFormatter :: Message -> Process (Maybe String) logLevelFormatter m = handleMessage m showLevel diff --git a/packages/distributed-process-extras/tests/TestPrimitives.hs b/packages/distributed-process-extras/tests/TestPrimitives.hs index baa9de42..fba6c2b7 100644 --- a/packages/distributed-process-extras/tests/TestPrimitives.hs +++ b/packages/distributed-process-extras/tests/TestPrimitives.hs @@ -16,11 +16,9 @@ import Control.Distributed.Process.Extras.Call import Control.Distributed.Process.Extras.Monitoring import Control.Distributed.Process.Extras.Time import Control.Monad (void) -import Control.Rematch hiding (match) -import qualified Network.Transport as NT (Transport) import Network.Transport.TCP() -import Test.HUnit (Assertion) +import Test.HUnit (Assertion, assertEqual, assertBool) import Test.Framework (Test, testGroup, defaultMain) import Test.Framework.Providers.HUnit (testCase) import Network.Transport.TCP @@ -113,8 +111,9 @@ testMonitorNodeDeath transport result = do mn1 <- liftIO $ takeMVar nid2 mn2 <- liftIO $ takeMVar nid3 - [mn1, mn2] `shouldContain` n1 - [mn1, mn2] `shouldContain` n2 + liftIO $ do + assertBool mempty $ n1 `elem` [mn1, mn2] + assertBool mempty $ n2 `elem` [mn1, mn2] nid4 <- liftIO $ newEmptyMVar node4 <- liftIO $ newLocalNode transport initRemoteTable @@ -125,7 +124,7 @@ testMonitorNodeDeath transport result = do mn3 <- liftIO $ takeMVar nid4 NodeUp n3 <- expect - mn3 `shouldBe` (equalTo n3) + liftIO $ assertEqual mempty n3 mn3 liftIO $ closeLocalNode node4 stash result () diff --git a/packages/distributed-process-extras/tests/TestQueues.hs b/packages/distributed-process-extras/tests/TestQueues.hs index 881a7f00..655035c4 100644 --- a/packages/distributed-process-extras/tests/TestQueues.hs +++ b/packages/distributed-process-extras/tests/TestQueues.hs @@ -1,26 +1,20 @@ {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Main where import qualified Control.Distributed.Process.Extras.Internal.Queue.SeqQ as FIFO import Control.Distributed.Process.Extras.Internal.Queue.SeqQ ( SeqQ ) import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as PQ -import Control.Rematch hiding (on) -import Control.Rematch.Run import Data.Function (on) -import Data.List +import Data.List ( sortBy ) import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertFailure) +import Test.HUnit (assertBool, assertEqual) import Prelude -expectThat :: a -> Matcher a -> Assertion -expectThat a matcher = case res of - MatchSuccess -> return () - (MatchFailure msg) -> assertFailure msg - where res = runMatch matcher a -- NB: these tests/properties are not meant to be complete, but rather -- they exercise the small number of behaviours that we actually use! @@ -72,13 +66,11 @@ tests = [ ], testGroup "FIFO Queue Tests" [ testCase "New Queue Should Be Empty" - (expectThat (FIFO.isEmpty $ FIFO.empty) $ equalTo True), + (assertBool mempty (FIFO.isEmpty $ FIFO.empty)), testCase "Singleton Queue Should Contain One Element" - (expectThat (FIFO.dequeue $ FIFO.singleton "hello") $ - equalTo $ Just ("hello", FIFO.empty)), + (assertEqual mempty (FIFO.dequeue $ FIFO.singleton "hello") $ Just ("hello", FIFO.empty)), testCase "Dequeue Empty Queue Should Be Nothing" - (expectThat (FIFO.dequeue $ (FIFO.empty :: SeqQ ())) $ - is (Nothing :: Maybe ((), SeqQ ()))), + (assertEqual mempty (FIFO.dequeue $ (FIFO.empty :: SeqQ ())) $ (Nothing :: Maybe ((), SeqQ ()))), testProperty "Enqueue/Dequeue should respect FIFO order" prop_fifo_enqueue, testProperty "Enqueue/Dequeue should respect isEmpty" diff --git a/packages/distributed-process-extras/tests/TestTimer.hs b/packages/distributed-process-extras/tests/TestTimer.hs index a021b2cb..4be9b7d2 100644 --- a/packages/distributed-process-extras/tests/TestTimer.hs +++ b/packages/distributed-process-extras/tests/TestTimer.hs @@ -9,7 +9,6 @@ import Control.Concurrent.MVar , takeMVar , withMVar ) -import qualified Network.Transport as NT (Transport) import Network.Transport.TCP() import Control.DeepSeq (NFData) import Control.Distributed.Process diff --git a/packages/distributed-process-supervisor/distributed-process-supervisor.cabal b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal index 0a5e9d8c..e1f60fff 100644 --- a/packages/distributed-process-supervisor/distributed-process-supervisor.cabal +++ b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal @@ -82,7 +82,6 @@ test-suite SupervisorTests stm, test-framework >= 0.6 && < 0.9, test-framework-hunit, - rematch >= 0.2.0.0, exceptions >= 0.10 && < 0.11 hs-source-dirs: tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind @@ -111,7 +110,6 @@ test-suite NonThreadedSupervisorTests stm, test-framework >= 0.6 && < 0.9, test-framework-hunit, - rematch >= 0.2.0.0, exceptions >= 0.10 && < 0.11 hs-source-dirs: tests ghc-options: -rtsopts -fno-warn-unused-do-bind -fno-warn-name-shadowing diff --git a/packages/distributed-process-supervisor/tests/TestSupervisor.hs b/packages/distributed-process-supervisor/tests/TestSupervisor.hs index 227e0b3f..16d345a7 100644 --- a/packages/distributed-process-supervisor/tests/TestSupervisor.hs +++ b/packages/distributed-process-supervisor/tests/TestSupervisor.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since -- they rely on ordering constraints which the Cloud Haskell runtime does not @@ -47,18 +47,11 @@ import Control.Distributed.Process.Serializable() import Control.Distributed.Static (staticLabel) import Control.Monad (void, unless, forM_, forM) import Control.Monad.Catch (finally) -import Control.Rematch - ( equalTo - , is - , isNot - , isNothing - , isJust - ) import Data.ByteString.Lazy (empty) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isNothing, isJust) -import Test.HUnit (Assertion, assertFailure) +import Test.HUnit (Assertion, assertFailure, assertEqual, assertBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import TestUtils hiding (waitForExit) @@ -119,7 +112,7 @@ permChild clj = ensureProcessIsAlive :: ProcessId -> Process () ensureProcessIsAlive pid = do result <- isProcessAlive pid - expectThat result $ is True + liftIO $ assertBool mempty result runInTestContext :: LocalNode -> MVar () @@ -178,7 +171,7 @@ verifyChildWasRestarted key pid sup = do -- TODO: handle (ChildRestarting _) too! case cSpec of Just (ref, _) -> do Just pid' <- resolve ref - expectThat pid' $ isNot $ equalTo pid + liftIO $ assertBool mempty ( pid' /= pid) _ -> do liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) @@ -195,7 +188,7 @@ verifyTempChildWasRemoved pid sup = do void $ waitForExit pid sleepFor 500 Millis cSpec <- lookupChild sup "temp-worker" - expectThat cSpec isNothing + liftIO $ assertBool mempty (isNothing cSpec) waitForExit :: ProcessId -> Process DiedReason waitForExit pid = do @@ -232,11 +225,11 @@ verifySingleRestart Context{..} key = do mx <- receiveChanTimeout t sniffer case mx of Just rs@SupervisedChildRestarting{} -> do - (childSpecKey rs) `shouldBe` equalTo key + liftIO $ assertEqual mempty (childSpecKey rs) key mx' <- receiveChanTimeout t sniffer case mx' of Just cs@SupervisedChildStarted{} -> do - (childSpecKey cs) `shouldBe` equalTo key + liftIO $ assertEqual mempty (childSpecKey cs) key debug logChannel $ "restart ok for " ++ (show cs) _ -> liftIO $ assertFailure $ " Unexpected Waiting Child Started " ++ (show mx') _ -> liftIO $ assertFailure $ "Unexpected Waiting Child Restarted " ++ (show mx) @@ -257,14 +250,14 @@ verifySeqStartOrder Context{..} xs toStop = do case mx of Just SupervisedChildRestarting{..} -> do debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs) - childSpecKey `shouldBe` equalTo (childKey cs) + liftIO $ assertEqual mempty childSpecKey (childKey cs) unless (childSpecKey == toStop) $ do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr) - childRef `shouldBe` equalTo oCr + liftIO $ assertEqual mempty childRef oCr mx' <- receiveChanTimeout t sniffer case mx' of - Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> do liftIO $ assertFailure $ "After Stopping " ++ (show cs) ++ " received unexpected " ++ (show mx) @@ -287,7 +280,7 @@ verifyStopStartOrder Context{..} xs restarted toStop = do case mx of Just SupervisedChildRestarting{..} -> do debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs) - childSpecKey `shouldBe` equalTo (childKey cs) + liftIO $ assertEqual mempty childSpecKey (childKey cs) if childSpecKey /= toStop then do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr) @@ -304,7 +297,7 @@ verifyStopStartOrder Context{..} xs restarted toStop = do debug logChannel $ "checking (reverse) start order for " ++ (show cr) mx <- receiveTimeout t [ matchChan sniffer return ] case mx of - Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) checkStartupOrder :: Context -> [Child] -> Process () @@ -314,7 +307,7 @@ checkStartupOrder Context{..} children = do debug logChannel $ "checking " ++ (show cr) mx <- receiveTimeout (asTimeout waitTimeout) [ matchChan sniffer return ] case mx of - Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) exitIgnore :: Process () @@ -469,7 +462,7 @@ addChildWithoutRestart :: ChildStart -> ProcessId -> Process () addChildWithoutRestart cs sup = let spec = transientWorker cs in do response <- addChild sup spec - response `shouldBe` equalTo (ChildAdded ChildStopped) + liftIO $ assertEqual mempty response (ChildAdded ChildStopped) addChildThenStart :: ChildStart -> ProcessId -> Process () addChildThenStart cs sup = @@ -479,7 +472,7 @@ addChildThenStart cs sup = case response of ChildStartOk (ChildRunning pid) -> do alive <- isProcessAlive pid - alive `shouldBe` equalTo True + liftIO $ assertBool mempty alive _ -> do liftIO $ putStrLn (show response) die "Ooops" @@ -487,13 +480,13 @@ addChildThenStart cs sup = startUnknownChild :: ChildStart -> ProcessId -> Process () startUnknownChild cs sup = do response <- startChild sup (childKey (transientWorker cs)) - response `shouldBe` equalTo ChildStartUnknownId + liftIO $ assertEqual mempty response ChildStartUnknownId setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec) setupChild cs sup = do let spec = transientWorker cs response <- addChild sup spec - response `shouldBe` equalTo (ChildAdded ChildStopped) + liftIO $ assertEqual mempty response (ChildAdded ChildStopped) Just child <- lookupChild sup "transient-worker" return child @@ -501,19 +494,19 @@ addDuplicateChild :: ChildStart -> ProcessId -> Process () addDuplicateChild cs sup = do (ref, spec) <- setupChild cs sup dup <- addChild sup spec - dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) + liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) startDuplicateChild :: ChildStart -> ProcessId -> Process () startDuplicateChild cs sup = do (ref, spec) <- setupChild cs sup dup <- startNewChild sup spec - dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) + liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) startBadClosure :: ChildStart -> ProcessId -> Process () startBadClosure cs sup = do let spec = tempWorker cs child <- startNewChild sup spec - child `shouldBe` equalTo + liftIO $ assertEqual mempty child (ChildFailedToStart $ StartFailureBadClosure "user error (Could not resolve closure: Invalid static label 'non-existing')") @@ -532,7 +525,7 @@ deleteExistingChild cs sup = do let spec = transientWorker cs (ChildAdded ref) <- startNewChild sup spec result <- deleteChild sup "transient-worker" - result `shouldBe` equalTo (ChildNotStopped ref) + liftIO $ assertEqual mempty result (ChildNotStopped ref) deleteStoppedTempChild :: ChildStart -> ProcessId -> Process () deleteStoppedTempChild cs sup = do @@ -543,7 +536,7 @@ deleteStoppedTempChild cs sup = do -- child needs to be stopped waitForExit pid result <- deleteChild sup (childKey spec) - result `shouldBe` equalTo ChildNotFound + liftIO $ assertEqual mempty result ChildNotFound deleteStoppedChild :: ChildStart -> ProcessId -> Process () deleteStoppedChild cs sup = do @@ -554,7 +547,7 @@ deleteStoppedChild cs sup = do -- child needs to be stopped waitForExit pid result <- deleteChild sup (childKey spec) - result `shouldBe` equalTo ChildDeleted + liftIO $ assertEqual mempty result ChildDeleted permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process () permanentChildrenAlwaysRestart cs sup = do @@ -601,7 +594,7 @@ transientChildrenExitShutdown cs Context{..} = do waitForDown mRef mx <- receiveChanTimeout 1000 sniffer :: Process (Maybe MxSupervisor) - expectThat mx isNothing + liftIO $ assertBool mempty (isNothing mx) verifyChildWasNotRestarted (childKey spec) pid sup intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () @@ -619,19 +612,19 @@ intrinsicChildrenNormalExit cs sup = do Just pid <- resolve ref testProcessStop pid reason <- waitForExit sup - expectThat reason $ equalTo DiedNormal + liftIO $ assertEqual mempty reason DiedNormal explicitRestartRunningChild :: ChildStart -> ProcessId -> Process () explicitRestartRunningChild cs sup = do let spec = tempWorker cs ChildAdded ref <- startNewChild sup spec result <- restartChild sup (childKey spec) - expectThat result $ equalTo $ ChildRestartFailed (StartFailureAlreadyRunning ref) + liftIO $ assertEqual mempty result (ChildRestartFailed (StartFailureAlreadyRunning ref)) explicitRestartUnknownChild :: ProcessId -> Process () explicitRestartUnknownChild sup = do result <- restartChild sup "unknown-id" - expectThat result $ equalTo ChildRestartUnknownId + liftIO $ assertEqual mempty result ChildRestartUnknownId explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process () explicitRestartRestartingChild cs sup = do @@ -660,7 +653,7 @@ explicitRestartStoppedChild cs sup = do restarted <- restartChild sup key sleepFor 500 Millis Just (ref', _) <- lookupChild sup key - expectThat ref $ isNot $ equalTo ref' + liftIO $ assertBool mempty (ref /= ref') case restarted of ChildRestartOk (ChildRunning _) -> return () _ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted) @@ -673,7 +666,7 @@ stopChildImmediately cs sup = do mRef <- monitor ref void $ stopChild sup (childKey spec) reason <- waitForDown mRef - expectThat reason $ equalTo $ DiedException (expectedExitReason sup) + liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) stoppingChildExceedsDelay :: ProcessId -> Process () stoppingChildExceedsDelay sup = do @@ -684,7 +677,7 @@ stoppingChildExceedsDelay sup = do mRef <- monitor ref void $ stopChild sup (childKey spec) reason <- waitForDown mRef - expectThat reason $ equalTo $ DiedException (expectedExitReason sup) + liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) stoppingChildObeysDelay :: ProcessId -> Process () stoppingChildObeysDelay sup = do @@ -732,7 +725,7 @@ delayedRestartAfterThreeAttempts withSupervisor = do case ref of ChildRestarting _ -> do SupervisedChildStarted{..} <- receiveChan sniffer - childSpecKey `shouldBe` equalTo (childKey spec) + liftIO $ assertEqual mempty childSpecKey (childKey spec) _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref) mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int] @@ -757,7 +750,7 @@ permanentChildExceedsRestartsIntensity cs withSupervisor = do void $ ((startNewChild sup spec >> return ()) `catchExit` (\_ (_ :: ExitReason) -> return ())) reason <- waitForDown ref - expectThat reason $ equalTo $ + liftIO $ assertEqual mempty reason $ DiedException $ "exit-from=" ++ (show sup) ++ ",reason=ReachedMaxRestartIntensity" @@ -841,7 +834,7 @@ restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' False -> return ()) ] - expectThat r isNothing + liftIO $ assertBool mempty (isNothing r) restartRightWithLeftToRightSeqRestarts :: ChildStart @@ -873,7 +866,7 @@ restartRightWithLeftToRightSeqRestarts cs withSupervisor = do True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' False -> return ()) ] - expectThat r isNothing + liftIO $ assertBool mempty (isNothing r) restartAllWithLeftToRightRestarts :: ProcessId -> Process () restartAllWithLeftToRightRestarts sup = do @@ -907,7 +900,7 @@ restartAllWithLeftToRightRestarts sup = do children' <- listChildren sup drainAllChildren children' let [c1, c2] = [map fst cs | cs <- [children, children']] - forM_ (zip c1 c2) $ \(p1, p2) -> expectThat p1 $ isNot $ equalTo p2 + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertBool mempty (p1 /= p2) where drainAllChildren children = do -- Receive all pids then verify they arrived in the correct order. @@ -977,7 +970,7 @@ expectLeftToRightRestarts ctx@Context{..} = do [ matchIf (\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs)) (\sig@(ProcessMonitorNotification _ _ _) -> return sig) ] - expectThat initRes $ isJust + liftIO $ assertBool mempty (isJust initRes) forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do (ProcessMonitorNotification ref' _ _) <- expect @@ -1022,7 +1015,7 @@ restartLeftWhenLeftmostChildDies cs sup = do verifyChildWasRestarted (childKey spec) pid sup Just (ref3, _) <- lookupChild sup "child2" Just pid2' <- resolve ref3 - pid2 `shouldBe` equalTo pid2' + liftIO $ assertEqual mempty pid2 pid2' restartWithoutTempChildren :: ChildStart -> ProcessId -> Process () restartWithoutTempChildren cs sup = do @@ -1044,8 +1037,9 @@ restartRightWhenRightmostChildDies cs sup = do (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } (ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" } [ch1, ch2] <- listChildren sup - (fst ch1) `shouldBe` equalTo ref2 - (fst ch2) `shouldBe` equalTo ref + liftIO $ do + assertEqual mempty (fst ch1) ref2 + assertEqual mempty (fst ch2) ref Just pid <- resolve ref Just pid2 <- resolve ref2 -- ref (and therefore pid) is 'rightmost' now @@ -1053,7 +1047,7 @@ restartRightWhenRightmostChildDies cs sup = do verifyChildWasRestarted "child1" pid sup Just (ref3, _) <- lookupChild sup "child2" Just pid2' <- resolve ref3 - pid2 `shouldBe` equalTo pid2' + liftIO $ assertEqual mempty pid2 pid2' restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process () restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do @@ -1084,7 +1078,7 @@ restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do verifyStopStartOrder ctx xs restarted toStop let [c1, c2] = [map fst cs | cs <- [(snd $ split children), notRestarted]] - forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartRightWithLeftToRightRestarts :: Bool -> Context -> Process () restartRightWithLeftToRightRestarts rev ctx@Context{..} = do @@ -1116,7 +1110,7 @@ restartRightWithLeftToRightRestarts rev ctx@Context{..} = do verifyStopStartOrder ctx xs restarted toStop let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]] - forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartRightWithRightToLeftRestarts :: Bool -> Context -> Process () restartRightWithRightToLeftRestarts rev ctx@Context{..} = do @@ -1148,7 +1142,7 @@ restartRightWithRightToLeftRestarts rev ctx@Context{..} = do verifyStopStartOrder ctx xs (reverse restarted) toStop let [c1, c2] = [map fst cs | cs <- [(fst $ split children), notRestarted]] - forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process () restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do @@ -1182,7 +1176,7 @@ restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do verifyStopStartOrder ctx xs (reverse restarted) toStop let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]] - forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 -- remote table definition and main diff --git a/packages/distributed-process-supervisor/tests/TestUtils.hs b/packages/distributed-process-supervisor/tests/TestUtils.hs index 60488b59..519882e8 100644 --- a/packages/distributed-process-supervisor/tests/TestUtils.hs +++ b/packages/distributed-process-supervisor/tests/TestUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,12 +8,7 @@ module TestUtils -- ping ! , Ping(Ping) , ping - , shouldBe - , shouldMatch - , shouldContain - , shouldNotContain , shouldExitWith - , expectThat -- test process utilities , TestProcessControl , startTestProcess @@ -66,9 +60,7 @@ import qualified Control.Exception as Exception import Control.Monad (forever) import Control.Monad.Catch (catch) import Control.Monad.STM (atomically) -import Control.Rematch hiding (match) -import Control.Rematch.Run -import Test.HUnit (Assertion, assertFailure) +import Test.HUnit (Assertion, assertEqual) import Test.HUnit.Base (assertBool) import Test.Framework (Test, defaultMain) import Control.DeepSeq @@ -80,32 +72,11 @@ import Data.Binary import Data.Typeable import GHC.Generics ---expect :: a -> Matcher a -> Process () ---expect a m = liftIO $ Rematch.expect a m - -expectThat :: a -> Matcher a -> Process () -expectThat a matcher = case res of - MatchSuccess -> return () - (MatchFailure msg) -> liftIO $ assertFailure msg - where res = runMatch matcher a - -shouldBe :: a -> Matcher a -> Process () -shouldBe = expectThat - -shouldContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldContain xs x = expectThat xs $ hasItem (equalTo x) - -shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) - -shouldMatch :: a -> Matcher a -> Process () -shouldMatch = expectThat - shouldExitWith :: (Resolvable a) => a -> DiedReason -> Process () shouldExitWith a r = do _ <- resolve a d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ] - d `shouldBe` equalTo r + liftIO $ assertEqual mempty d r waitForExit :: MVar ExitReason -> Process (Maybe ExitReason) diff --git a/packages/distributed-process-systest/distributed-process-systest.cabal b/packages/distributed-process-systest/distributed-process-systest.cabal index fbbe9652..65bbf0f1 100644 --- a/packages/distributed-process-systest/distributed-process-systest.cabal +++ b/packages/distributed-process-systest/distributed-process-systest.cabal @@ -41,7 +41,6 @@ library network-transport >= 0.4.1.0 && < 0.6, network >= 2.5 && < 3.3, random >= 1.0 && < 1.3, - rematch >= 0.1.2.1 && < 0.3, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2.0 && < 0.4, exceptions < 0.11, diff --git a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs index 435a5fae..5e8b451e 100644 --- a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs +++ b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs @@ -19,11 +19,6 @@ module Control.Distributed.Process.SysTest.Utils -- ping ! , Ping(Ping) , ping - , shouldBe - , shouldMatch - , shouldContain - , shouldNotContain - , expectThat , synchronisedAssertion -- test process utilities , TestProcessControl @@ -77,12 +72,10 @@ import Control.Monad.Catch import Control.Exception (AsyncException(ThreadKilled)) import Control.Monad (forever) import Control.Monad.STM (atomically) -import Control.Rematch hiding (match) -import Control.Rematch.Run import Data.Binary import Data.Typeable (Typeable) -import Test.HUnit (Assertion, assertFailure) +import Test.HUnit (Assertion) import Test.HUnit.Base (assertBool) import GHC.Generics @@ -128,24 +121,6 @@ synchronisedAssertion note localNode expected testProc lock = do stash :: TestResult a -> a -> Process () stash mvar x = liftIO $ putMVar mvar x -expectThat :: a -> Matcher a -> Process () -expectThat a matcher = case res of - MatchSuccess -> return () - (MatchFailure msg) -> liftIO $ assertFailure msg - where res = runMatch matcher a - -shouldBe :: a -> Matcher a -> Process () -shouldBe = expectThat - -shouldContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldContain xs x = expectThat xs $ hasItem (equalTo x) - -shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) - -shouldMatch :: a -> Matcher a -> Process () -shouldMatch = expectThat - -- | Run the supplied @testProc@ using an @MVar@ to collect and assert -- against its result. Uses the supplied @note@ if the assertion fails. delayedAssertion :: (Eq a) => String -> LocalNode -> a -> diff --git a/stack-ghc-8.10.7.yaml b/stack-ghc-8.10.7.yaml index a23ec9ca..d95062ab 100644 --- a/stack-ghc-8.10.7.yaml +++ b/stack-ghc-8.10.7.yaml @@ -21,5 +21,4 @@ packages: flags: distributed-process-tests: tcp: true -extra-deps: -- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 + diff --git a/stack-ghc-9.0.2.yaml b/stack-ghc-9.0.2.yaml index 3af58cf7..262896a4 100644 --- a/stack-ghc-9.0.2.yaml +++ b/stack-ghc-9.0.2.yaml @@ -21,5 +21,4 @@ packages: flags: distributed-process-tests: tcp: true -extra-deps: -- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 + diff --git a/stack-ghc-9.2.7.yaml b/stack-ghc-9.2.7.yaml index f48da6bf..ac12790c 100644 --- a/stack-ghc-9.2.7.yaml +++ b/stack-ghc-9.2.7.yaml @@ -21,5 +21,3 @@ packages: flags: distributed-process-tests: tcp: true -extra-deps: -- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.4.5.yaml b/stack-ghc-9.4.5.yaml index 806cd43c..f41b5df0 100644 --- a/stack-ghc-9.4.5.yaml +++ b/stack-ghc-9.4.5.yaml @@ -21,5 +21,3 @@ packages: flags: distributed-process-tests: tcp: true -extra-deps: -- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.8.2.yaml b/stack-ghc-9.8.2.yaml index 227f6d12..9ab940df 100644 --- a/stack-ghc-9.8.2.yaml +++ b/stack-ghc-9.8.2.yaml @@ -21,5 +21,3 @@ packages: flags: distributed-process-tests: tcp: true -extra-deps: -- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245