summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs67
1 files changed, 1 insertions, 66 deletions
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 })