diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Process.hs | 2 | ||||
| -rw-r--r-- | src/Run.hs | 4 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 10 | ||||
| -rw-r--r-- | src/Test.hs | 11 |
4 files changed, 19 insertions, 8 deletions
diff --git a/src/Process.hs b/src/Process.hs index 0c24b4f..57411d7 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -178,7 +178,7 @@ closeProcess timeout p = do closeTestProcess :: Process -> TestRun () closeTestProcess process = do - timeout <- liftIO . readMVar =<< asks (teTimeout . fst) + timeout <- getCurrentTimeout closeProcess timeout process withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a @@ -60,7 +60,7 @@ runTest out opts gdefs test = do failedVar <- newTVarIO Nothing objIdVar <- newMVar 1 procVar <- newMVar [] - timeoutVar <- newMVar $ optTimeout opts + timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do @@ -321,7 +321,7 @@ exprFailed desc stack pname = do expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () expect sline p (Traced trace re) tvars inner = do - timeout <- liftIO . readMVar =<< asks (teTimeout . fst) + timeout <- getCurrentTimeout 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 f681e99..c742987 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -8,6 +8,8 @@ module Run.Monad ( finally, forkTest, forkTestUsing, + + getCurrentTimeout, ) where import Control.Concurrent @@ -43,7 +45,7 @@ data TestEnv = TestEnv , teOptions :: TestOptions , teNextObjId :: MVar Int , teProcesses :: MVar [ Process ] - , teTimeout :: MVar Scientific + , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } @@ -130,3 +132,9 @@ forkTestUsing fork act = do case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () + +getCurrentTimeout :: TestRun Scientific +getCurrentTimeout = do + ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst) + return $ if zeros > 0 then 0 + else timeout diff --git a/src/Test.hs b/src/Test.hs index ce88052..18933b1 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -10,6 +10,7 @@ import Control.Concurrent.MVar import Control.Monad.Except import Control.Monad.Reader +import Data.Bifunctor import Data.Scientific import Data.Text (Text) import Data.Typeable @@ -67,15 +68,17 @@ instance ObjectType TestRun MultiplyTimeout where type ConstructorArgs MultiplyTimeout = Scientific createObject oid timeout - | timeout > 0 = do + | timeout >= 0 = do var <- asks (teTimeout . fst) - liftIO $ modifyMVar_ var $ return . (* timeout) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (+ 1) else first (* timeout)) return $ Object oid $ MultiplyTimeout timeout | otherwise = do - outLine OutputError Nothing "timeout must be positive" + outLine OutputError Nothing "timeout must not be negative" throwError Failed destroyObject Object { objImpl = MultiplyTimeout timeout } = do var <- asks (teTimeout . fst) - liftIO $ modifyMVar_ var $ return . (/ timeout) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (subtract 1) else first (/ timeout)) |