diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2025-06-19 22:24:00 +0200 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2025-06-21 15:59:51 +0200 |
commit | b7eb345a88df9ee87080fe776722f12e911b773f (patch) | |
tree | ae66d29255f35b44cfcbc7de8cc6d083d002d39c /src/Run | |
parent | da73a6777c2e4b7b4a54830c781a6e5bb2cb86fe (diff) |
Diffstat (limited to 'src/Run')
-rw-r--r-- | src/Run/Monad.hs | 17 |
1 files changed, 13 insertions, 4 deletions
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index abef32d..aeab7e4 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -15,6 +15,7 @@ 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.Scientific @@ -26,15 +27,22 @@ import Network.Ip import Output import {-# SOURCE #-} Process 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 ] , teGDB :: Maybe (MVar GDB) } @@ -117,6 +125,7 @@ forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId forkTestUsing fork act = do tenv <- ask liftIO $ fork $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () |