summaryrefslogtreecommitdiff
path: root/src/Run
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2025-06-19 22:24:00 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2025-06-21 15:59:51 +0200
commitb7eb345a88df9ee87080fe776722f12e911b773f (patch)
treeae66d29255f35b44cfcbc7de8cc6d083d002d39c /src/Run
parentda73a6777c2e4b7b4a54830c781a6e5bb2cb86fe (diff)
Object type with constructors and destructorsHEADmaster
Diffstat (limited to 'src/Run')
-rw-r--r--src/Run/Monad.hs17
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 ()