diff options
Diffstat (limited to 'src/Run/Monad.hs')
-rw-r--r-- | src/Run/Monad.hs | 44 |
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 () |