diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2022-12-20 21:21:30 +0100 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2022-12-20 21:21:30 +0100 |
commit | a5f0062f48fba018e7de8b5a3c0799381e535572 (patch) | |
tree | 985e7bd3f4ed045f352a11cc29831c717450fc24 /src/Main.hs | |
parent | 739d8e3f7b2e418a17e13c908aefcbb4c6c150f6 (diff) |
Move TestRun monad and related types to separate module
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 }) |