Support zero timeout

Changelog: Support zero as a timeout multiplyer

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
diff --git a/src/Run.hs b/src/Run.hs
index 2e5d641..f7071b9 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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))