summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/GDB.hs-boot6
-rw-r--r--src/Main.hs67
-rw-r--r--src/Process.hs1
-rw-r--r--src/Run/Monad.hs91
-rw-r--r--src/Test.hs4
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