diff options
| -rw-r--r-- | README.md | 7 | ||||
| -rw-r--r-- | src/Run.hs | 4 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 1 | ||||
| -rw-r--r-- | src/Test.hs | 27 | ||||
| -rw-r--r-- | src/Test/Builtins.hs | 7 |
5 files changed, 45 insertions, 1 deletions
@@ -336,6 +336,13 @@ with <expr>: Execute `<test block>` with `<expr>` as context. ``` +multiply_timeout by <multiplier> +``` + +Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`. +The effect lasts until the end of the block. + +``` wait ``` @@ -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 |