diff options
Diffstat (limited to 'src/Main.hs')
-rw-r--r-- | src/Main.hs | 67 |
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 }) |