coot/timeout fix

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -257,14 +257,14 @@ schedule !thread@Thread{
         locked <- readSTRef isLockedRef
         case locked of
           Locked etid -> do
-            let -- Kill the assassin throwing thread and carry on the
-                -- continuation
+            let -- Kill the assassin throwing thread then unmask exceptions and
+                -- carry on the continuation
                 thread' =
                   thread { threadControl =
                             ThreadControl (ThrowTo (toException ThreadKilled)
                                                    etid
-                                                   (k (Just x)))
-                                          ctl'
+                                                   (Return ()))
+                                          (MaskFrame (\_ -> k (Just x)) maskst ctl')
                          , threadMasking = MaskedUninterruptible
                          }
             schedule thread' simstate
@@ -939,7 +939,7 @@ unblockThreads !wakeup !simstate@SimState {runqueue, threads} =
 -- receive a 'ThreadKilled' exception.
 --
 forkTimeoutInterruptThreads :: forall s a.
-                              [(ThreadId, TimeoutId, STRef s IsLocked, IsLocked)]
+                               [(ThreadId, TimeoutId, STRef s IsLocked, IsLocked)]
                             -> SimState s a
                             -> ST s (SimState s a)
 forkTimeoutInterruptThreads timeoutExpired simState@SimState {threads} =

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -363,14 +363,14 @@ schedule thread@Thread{
         locked <- readSTRef isLockedRef
         case locked of
           Locked etid -> do
-            let -- Kill the exception throwing thread and carry on the
-                -- continuation
+            let -- Kill the assassin throwing thread then unmask exceptions and
+                -- carry on the continuation
                 thread' =
                   thread { threadControl =
                             ThreadControl (ThrowTo (toException ThreadKilled)
                                                    etid
-                                                   (k (Just x)))
-                                          ctl'
+                                                   (Return ()))
+                                          (MaskFrame (\_ -> k (Just x)) maskst ctl')
                          , threadMasking = MaskedUninterruptible
                          }
             schedule thread' simstate

io-sim/test/Test/Control/Monad/IOSim.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE NumericUnderscores  #-}
 {-# LANGUAGE RankNTypes          #-}
@@ -11,6 +12,10 @@ module Test.Control.Monad.IOSim
   ( tests
   , TestThreadGraph (..)
     -- * Timeout tests
+  , WithSanityCheck (..)
+  , withSanityCheck
+  , ignoreSanityCheck
+  , isSanityCheckIgnored
   , TimeoutConstraints
   , TimeoutDuration
   , ActionDuration
@@ -47,7 +52,6 @@ import           Test.Tasty.QuickCheck
 
 import           GHC.Conc (ThreadStatus(..))
 
-
 tests :: TestTree
 tests =
   testGroup "IO simulator"
@@ -1033,6 +1037,8 @@ type TimeoutConstraints m =
       , MonadTimer m
       , MonadMask  m
       , MonadThrow (STM m)
+      , MonadSay   m
+      , MonadMaskingState m
       )
 
 instance Arbitrary DiffTime where
@@ -1053,7 +1059,7 @@ singleTimeoutExperiment
     :: TimeoutConstraints m
     => TimeoutDuration
     -> ActionDuration
-    -> m Property
+    -> m (WithSanityCheck Property)
 singleTimeoutExperiment intendedTimeoutDuration
                         intendedActionDuration = do
 
@@ -1062,6 +1068,7 @@ singleTimeoutExperiment intendedTimeoutDuration
               -- Allow the action to run for intendedTimeoutDuration
     result <- timeout intendedTimeoutDuration $ do
 
+                  getMaskingState >>= say . show
                   -- Simulate an action that should take intendedActionDuration
                   threadDelay intendedActionDuration
 
@@ -1074,62 +1081,120 @@ singleTimeoutExperiment intendedTimeoutDuration
                               intendedActionDuration
                               before after result
 
+data WithSanityCheck prop
+  = WithSanityCheck        prop
+
+  -- | The first one represents the property without sanity check, the other one
+  -- sanity check (which failed). It is kept to keep its `counterexample`s.
+  | WithSanityCheckFailure prop prop
+  deriving (Functor)
+
+ignoreSanityCheck :: WithSanityCheck prop -> prop
+ignoreSanityCheck (WithSanityCheck    prop)       = prop
+ignoreSanityCheck (WithSanityCheckFailure prop _) = prop
+
+withSanityCheck :: WithSanityCheck Property -> Property
+withSanityCheck (WithSanityCheck        prop)             = prop
+withSanityCheck (WithSanityCheckFailure prop sanityCheck) = prop .&&. sanityCheck
+
+isSanityCheckIgnored :: WithSanityCheck prop -> Bool
+isSanityCheckIgnored WithSanityCheck{}         = False
+isSanityCheckIgnored WithSanityCheckFailure {} = True
+
+
 experimentResult :: TimeoutDuration
                  -> ActionDuration
                  -> Time
                  -> Time
                  -> Maybe Time
-                 -> Property
+                 -> WithSanityCheck Property
 experimentResult intendedTimeoutDuration
                  intendedActionDuration
                  before after result =
     counterexamples
       [ "intendedTimeoutDuration: " ++ show intendedTimeoutDuration
       , "intendedActionDuration:  " ++ show intendedActionDuration
       , "actualOverallDuration:   " ++ show actualOverallDuration
-      ] $ timeoutCheck
+      ] <$>
+      if ignoredSanityCheck
+        then WithSanityCheckFailure timeoutCheck sanityCheck
+        else WithSanityCheck $ sanityCheck .&&. timeoutCheck
   where
     actualOverallDuration   = diffTime after before
+    intendedOverallDuration = min intendedTimeoutDuration intendedActionDuration
+
+    ignoredSanityCheck =
+         actualOverallDuration < intendedOverallDuration
+      || actualOverallDuration > intendedOverallDuration
+
+    sanityCheck = counterexample "sanityCheckLow"  sanityCheckLow
+             .&&. counterexample "sanityCheckHigh" sanityCheckHigh
+
+    sanityCheckLow =
+      actualOverallDuration >= intendedOverallDuration
+
+    sanityCheckHigh =
+      actualOverallDuration <= intendedOverallDuration
 
     timeoutCheck =
       case result of
         Nothing ->
           counterexamples
-            [ "timeout fired"
+            [ "timeout fired (but should not have)"
             , "violation of timeout property:\n" ++
-              "  actualOverallDuration == intendedTimeoutDuration"
+              "  actualOverallDuration >= intendedTimeoutDuration"
             ] $
-          actualOverallDuration === intendedTimeoutDuration
+          actualOverallDuration >= intendedTimeoutDuration
 
         Just afterAction ->
           let actualActionDuration = diffTime afterAction before in
           counterexamples
             [ "actualActionDuration:  " ++ show actualActionDuration
-            , "timeout did not fire"
+            , "timeout did not fire (but should not have)"
             , "violation of timeout property:\n" ++
-              "  actualActionDuration == intendedTimeoutDuration"
+              "  actualActionDuration <= intendedTimeoutDuration"
             ] $
-          actualActionDuration === intendedActionDuration
+          actualActionDuration <= intendedActionDuration
 
 
 prop_timeout
     :: TimeoutDuration
     -> ActionDuration
     -> Property
 prop_timeout intendedTimeoutDuration intendedActionDuration = 
-    runSimOrThrow (singleTimeoutExperiment intendedTimeoutDuration intendedActionDuration)
+    runSimOrThrow (withSanityCheck <$>
+                    singleTimeoutExperiment
+                      intendedTimeoutDuration
+                      intendedActionDuration)
+
 
 prop_timeouts
     :: [(TimeoutDuration, ActionDuration)]
     -> Property
-prop_timeouts times = runSimOrThrow $
-      conjoin <$>
-      sequence
-        [ counterexample ("failure on timeout test #" ++ show n)
-          <$> singleTimeoutExperiment intendedTimeoutDuration
-                                      intendedActionDuration
-        | ((intendedTimeoutDuration,
-            intendedActionDuration), n) <- zip times [1 :: Int ..] ]
+prop_timeouts times =
+    counterexample (ppTrace_ trace) $
+    either (\e -> counterexample (show e) False) id $
+    traceResult False trace
+  where
+    trace =
+      runSimTrace $
+        conjoin' <$>
+        sequence
+          [ fmap (counterexample ("failure on timeout test #" ++ show n))
+            <$> singleTimeoutExperiment intendedTimeoutDuration
+                                        intendedActionDuration
+          | ((intendedTimeoutDuration,
+              intendedActionDuration), n) <- zip times [1 :: Int ..] ]
+
+    maxFailures = 0
+
+    conjoin' :: [WithSanityCheck Property] -> Property
+    conjoin' props =
+           conjoin (ignoreSanityCheck `map` props)
+      .&&. let numFailures = length (filter isSanityCheckIgnored props)
+           in counterexample
+               ("too many failures: " ++ show numFailures ++ " ≰ " ++ show maxFailures)
+               (numFailures <= maxFailures)
 
 --
 -- MonadMask properties

io-sim/test/Test/Control/Monad/IOSimPOR.hs

@@ -38,7 +38,9 @@ import           Control.Monad.IOSim
 import           GHC.Generics
 
 import           Test.Control.Monad.IOSim (TimeoutDuration, ActionDuration,
-                   singleTimeoutExperiment)
+                   WithSanityCheck (..), ignoreSanityCheck,
+                   isSanityCheckIgnored, singleTimeoutExperiment,
+                   withSanityCheck)
 import           Test.Control.Monad.Utils
 import           Test.Control.Monad.STM
 
@@ -855,7 +857,7 @@ prop_timeout intendedTimeoutDuration intendedActionDuration =
     experiment :: IOSim s Property
     experiment = do
       exploreRaces
-      singleTimeoutExperiment intendedTimeoutDuration intendedActionDuration
+      withSanityCheck <$> singleTimeoutExperiment intendedTimeoutDuration intendedActionDuration
 
 prop_timeouts
     :: [(TimeoutDuration, ActionDuration)]
@@ -868,14 +870,24 @@ prop_timeouts times = exploreSimTrace id experiment $ \_ trace ->
     experiment :: IOSim s Property
     experiment = do
       exploreRaces
-      conjoin <$>
+      conjoin' <$>
         sequence
-          [ counterexample ("failure on timeout test #" ++ show n)
+          [ fmap (counterexample ("failure on timeout test #" ++ show n))
             <$> singleTimeoutExperiment intendedTimeoutDuration
                                         intendedActionDuration
           | ((intendedTimeoutDuration,
               intendedActionDuration), n) <- zip times [1 :: Int ..] ]
 
+    maxFailures = 0
+
+    conjoin' :: [WithSanityCheck Property] -> Property
+    conjoin' props =
+           conjoin (ignoreSanityCheck `map` props)
+      .&&. let numFailures = length (filter isSanityCheckIgnored props)
+           in counterexample
+               ("too many failures: " ++ show numFailures ++ " ≰ " ++ show maxFailures)
+               (numFailures <= maxFailures)
+
 --
 -- MonadMask properties
 --