Multiply-timeout command

Changelog: Added `multiply_timeout` command

4 files changed, 38 insertions, 1 deletions

diff --git a/src/Run.hs b/src/Run.hs
index 2d5029d..4d68fb6 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -59,6 +59,7 @@ runTest out opts gdefs test = do
     failedVar <- newTVarIO Nothing
     objIdVar <- newMVar 1
     procVar <- newMVar []
+    timeoutVar <- newMVar $ optTimeout opts
 
     mgdb <- if optGDB opts
         then flip runReaderT out $ do
@@ -72,6 +73,7 @@ runTest out opts gdefs test = do
             , teOptions = opts
             , teNextObjId = objIdVar
             , teProcesses = procVar
+            , teTimeout = timeoutVar
             , teGDB = fst <$> mgdb
             }
         tstate = TestState
@@ -313,7 +315,7 @@ exprFailed desc sline pname exprVars = do
 
 expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
 expect sline p (Traced trace re) tvars inner = do
-    timeout <- asks $ optTimeout . teOptions . fst
+    timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
     delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
     mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
         line <- readTVar (procOutput p)
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index aeab7e4..f681e99 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -43,6 +43,7 @@ data TestEnv = TestEnv
     , teOptions :: TestOptions
     , teNextObjId :: MVar Int
     , teProcesses :: MVar [ Process ]
+    , teTimeout :: MVar Scientific
     , teGDB :: Maybe (MVar GDB)
     }
 
diff --git a/src/Test.hs b/src/Test.hs
index 6c44e94..3e98efa 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -2,13 +2,20 @@ module Test (
     Test(..),
     TestStep(..),
     TestBlock(..),
+
+    MultiplyTimeout(..),
 ) where
 
+import Control.Concurrent.MVar
+import Control.Monad.Except
+import Control.Monad.Reader
+
 import Data.Scientific
 import Data.Text (Text)
 import Data.Typeable
 
 import Network
+import Output
 import Process
 import Run.Monad
 import Script.Expr
@@ -52,3 +59,23 @@ data TestStep a where
 instance Typeable a => ExprType (TestBlock a) where
     textExprType _ = "test block"
     textExprValue _ = "<test block>"
+
+
+data MultiplyTimeout = MultiplyTimeout Scientific
+
+instance ObjectType TestRun MultiplyTimeout where
+    type ConstructorArgs MultiplyTimeout = Scientific
+
+    createObject oid timeout
+        | timeout > 0 = do
+            var <- asks (teTimeout . fst)
+            liftIO $ modifyMVar_ var $ return . (* timeout)
+            return $ Object oid $ MultiplyTimeout timeout
+
+        | otherwise = do
+            outLine OutputError Nothing "timeout must be positive"
+            throwError Failed
+
+    destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+        var <- asks (teTimeout . fst)
+        liftIO $ modifyMVar_ var $ return . (/ timeout)
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 69579bc..6dba707 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -4,6 +4,8 @@ module Test.Builtins (
 
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Proxy
+import Data.Scientific
 import Data.Text (Text)
 
 import Process (Process)
@@ -15,6 +17,7 @@ builtins = M.fromList
     [ fq "send" builtinSend
     , fq "flush" builtinFlush
     , fq "guard" builtinGuard
+    , fq "multiply_timeout" builtinMultiplyTimeout
     , fq "wait" builtinWait
     ]
   where
@@ -53,5 +56,9 @@ builtinGuard :: SomeVarValue
 builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
     \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
 
+builtinMultiplyTimeout :: SomeVarValue
+builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
+    \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))
+
 builtinWait :: SomeVarValue
 builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait