Move TestRun monad and related types to separate module

6 files changed, 100 insertions, 70 deletions

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index f869075..47c3639 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -39,6 +39,7 @@ executable erebos-tester-core
                        Output
                        Parser
                        Process
+                       Run.Monad
                        Test
                        Util
   other-extensions:    TemplateHaskell
diff --git a/src/GDB.hs-boot b/src/GDB.hs-boot
new file mode 100644
index 0000000..608ba7c
--- /dev/null
+++ b/src/GDB.hs-boot
@@ -0,0 +1,6 @@
+module GDB where
+
+import Output
+
+data GDB
+gdbSession :: MonadOutput m => GDB -> m ()
diff --git a/src/Main.hs b/src/Main.hs
index 8864883..1c1f03c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,7 +9,6 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
-import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe
 import Data.Scientific
@@ -35,74 +34,10 @@ import Network
 import Output
 import Parser
 import Process
+import Run.Monad
 import Test
 import Util
 
-data Options = Options
-    { optDefaultTool :: String
-    , optProcTools :: [(ProcName, String)]
-    , optTestDir :: FilePath
-    , optVerbose :: Bool
-    , optTimeout :: Scientific
-    , optGDB :: Bool
-    , optForce :: Bool
-    }
-
-defaultOptions :: Options
-defaultOptions = Options
-    { optDefaultTool = ""
-    , optProcTools = []
-    , optTestDir = ".test"
-    , optVerbose = False
-    , optTimeout = 1
-    , optGDB = False
-    , optForce = False
-    }
-
-data TestEnv = TestEnv
-    { teOutput :: Output
-    , teFailed :: TVar (Maybe Failed)
-    , teOptions :: Options
-    , teProcesses :: MVar [Process]
-    , teGDB :: Maybe (MVar GDB)
-    }
-
-data TestState = TestState
-    { tsNetwork :: Network
-    , tsVars :: [(VarName, SomeVarValue)]
-    , tsNodePacketLoss :: Map NodeName Scientific
-    }
-
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
-    deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
-
-instance MonadFail TestRun where
-    fail str = do
-        outLine OutputError Nothing $ T.pack str
-        throwError Failed
-
-instance MonadError Failed TestRun where
-    throwError failed = do
-        failedVar <- asks $ teFailed . fst
-        liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed)
-
-        te <- asks fst
-        case failed of
-            ProcessCrashed _ | Just mgdb <- teGDB te -> do
-                maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb)
-            _ -> return ()
-
-        TestRun $ throwError failed
-
-    catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
-
-instance MonadEval TestRun where
-    lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)
-    rootNetwork = asks $ tsNetwork . snd
-
-instance MonadOutput TestRun where
-    getOutput = asks $ teOutput . fst
-
 withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
 withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
 
diff --git a/src/Process.hs b/src/Process.hs
index a1a421f..9979f41 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -26,6 +26,7 @@ import System.Process
 
 import Network
 import Output
+import Run.Monad
 import Test
 
 data Process = Process
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
new file mode 100644
index 0000000..77e47ea
--- /dev/null
+++ b/src/Run/Monad.hs
@@ -0,0 +1,91 @@
+module Run.Monad (
+    TestRun(..),
+    TestEnv(..),
+    TestState(..),
+    Options(..), defaultOptions,
+    Failed(..),
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Map (Map)
+import Data.Scientific
+import qualified Data.Text as T
+
+import {-# SOURCE #-} GDB
+import {-# SOURCE #-} Network
+import Output
+import {-# SOURCE #-} Process
+import Test
+
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
+    deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+
+data TestEnv = TestEnv
+    { teOutput :: Output
+    , teFailed :: TVar (Maybe Failed)
+    , teOptions :: Options
+    , teProcesses :: MVar [Process]
+    , teGDB :: Maybe (MVar GDB)
+    }
+
+data TestState = TestState
+    { tsNetwork :: Network
+    , tsVars :: [(VarName, SomeVarValue)]
+    , tsNodePacketLoss :: Map NodeName Scientific
+    }
+
+data Options = Options
+    { optDefaultTool :: String
+    , optProcTools :: [(ProcName, String)]
+    , optTestDir :: FilePath
+    , optVerbose :: Bool
+    , optTimeout :: Scientific
+    , optGDB :: Bool
+    , optForce :: Bool
+    }
+
+defaultOptions :: Options
+defaultOptions = Options
+    { optDefaultTool = ""
+    , optProcTools = []
+    , optTestDir = ".test"
+    , optVerbose = False
+    , optTimeout = 1
+    , optGDB = False
+    , optForce = False
+    }
+
+data Failed = Failed
+            | ProcessCrashed Process
+
+instance MonadFail TestRun where
+    fail str = do
+        outLine OutputError Nothing $ T.pack str
+        throwError Failed
+
+instance MonadError Failed TestRun where
+    throwError failed = do
+        failedVar <- asks $ teFailed . fst
+        liftIO $ atomically $ modifyTVar failedVar (`mplus` Just failed)
+
+        te <- asks fst
+        case failed of
+            ProcessCrashed _ | Just mgdb <- teGDB te -> do
+                maybe (return ()) gdbSession =<< liftIO (tryTakeMVar mgdb)
+            _ -> return ()
+
+        TestRun $ throwError failed
+
+    catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
+
+instance MonadEval TestRun where
+    lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)
+    rootNetwork = asks $ tsNetwork . snd
+
+instance MonadOutput TestRun where
+    getOutput = asks $ teOutput . fst
diff --git a/src/Test.hs b/src/Test.hs
index 16936bb..11cbca8 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,7 +1,6 @@
 module Test (
     Test(..),
     TestStep(..),
-    Failed(..),
     SourceLine(..),
 
     MonadEval(..),
@@ -42,9 +41,6 @@ data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestSte
               | PacketLoss (Expr Scientific) (Expr Node) [TestStep]
               | Wait
 
-data Failed = Failed
-            | ProcessCrashed Process
-
 newtype SourceLine = SourceLine Text