summaryrefslogtreecommitdiff
path: root/src/Run/Monad.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Run/Monad.hs')
-rw-r--r--src/Run/Monad.hs44
1 files changed, 29 insertions, 15 deletions
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 9ec9065..f681e99 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -7,6 +7,7 @@ module Run.Monad (
finally,
forkTest,
+ forkTestUsing,
) where
import Control.Concurrent
@@ -14,33 +15,41 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
+import Control.Monad.Writer
import Data.Map (Map)
-import Data.Set (Set)
import Data.Scientific
-import qualified Data.Text as T
+import Data.Set (Set)
+import Data.Text qualified as T
import {-# SOURCE #-} GDB
-import {-# SOURCE #-} Network
import Network.Ip
import Output
import {-# SOURCE #-} Process
-import Test
+import Script.Expr
+import Script.Object
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
- deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }
+ deriving
+ ( Functor, Applicative, Monad
+ , MonadReader ( TestEnv, TestState )
+ , MonadWriter [ SomeObject TestRun ]
+ , MonadIO
+ )
data TestEnv = TestEnv
{ teOutput :: Output
, teFailed :: TVar (Maybe Failed)
, teOptions :: TestOptions
- , teProcesses :: MVar [Process]
+ , teNextObjId :: MVar Int
+ , teProcesses :: MVar [ Process ]
+ , teTimeout :: MVar Scientific
, teGDB :: Maybe (MVar GDB)
}
data TestState = TestState
- { tsNetwork :: Network
- , tsVars :: [(VarName, SomeVarValue)]
+ { tsGlobals :: GlobalDefs
+ , tsLocals :: [ ( VarName, SomeVarValue ) ]
, tsDisconnectedUp :: Set NetworkNamespace
, tsDisconnectedBridge :: Set NetworkNamespace
, tsNodePacketLoss :: Map NetworkNamespace Scientific
@@ -93,8 +102,9 @@ instance MonadError Failed TestRun where
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
+ askGlobalDefs = asks (tsGlobals . snd)
+ askDictionary = asks (tsLocals . snd)
+ withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) })
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
@@ -109,10 +119,14 @@ finally act handler = do
void handler
return x
-forkTest :: TestRun () -> TestRun ()
-forkTest act = do
+forkTest :: TestRun () -> TestRun ThreadId
+forkTest = forkTestUsing forkIO
+
+forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
+forkTestUsing fork act = do
tenv <- ask
- void $ liftIO $ forkIO $ do
- runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+ liftIO $ fork $ do
+ ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+ case res of
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()