Temp

strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase    #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF where
 
@@ -37,11 +38,11 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WH
   where
     testIO name inv = testGroup name [
           testProperty "prop_newTVarWithInvariant" $
-            monadicIO .: prop_newTVarWithInvariant inv
+            monadicIO .: runWithCounterexample .: prop_newTVarWithInvariant inv
         , testProperty "prop_newTVarWithInvariantIO" $
             monadicIO .: prop_newTVarWithInvariantIO inv
         , testProperty "prop_writeTVar" $
-            monadicIO .: prop_writeTVar inv
+            monadicIO .: runWithCounterexample .: prop_writeTVar inv
         , testProperty "prop_modifyTVar" $
             monadicIO .: prop_modifyTVar inv
         , testProperty "prop_stateTVar" $
@@ -52,11 +53,11 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WH
 
     testIOSim name inv = testGroup name [
           testProperty "prop_newTVarWithInvariant" $ \x f ->
-            monadicSim $ prop_newTVarWithInvariant inv x f
+            monadicSim $ runWithCounterexample $ prop_newTVarWithInvariant inv x f
         , testProperty "prop_newTVarWithInvariantIO" $ \x f ->
             monadicSim $ prop_newTVarWithInvariantIO inv x f
         , testProperty "prop_writeTVar" $ \x f ->
-            monadicSim $ prop_writeTVar inv x f
+            monadicSim $ runWithCounterexample $ prop_writeTVar inv x f
         , testProperty "prop_modifyTVar" $ \x f ->
             monadicSim $ prop_modifyTVar inv x f
         , testProperty "prop_stateTVar" $ \x f ->
@@ -82,6 +83,15 @@ isInWHNF v = do
       Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)
                  >> pure False
 
+isInWHNF' :: (MonadSTM m, Typeable a) => StrictTVar m a -> m (Maybe String)
+isInWHNF' v = fmap show . unsafeNoThunks . OnlyCheckWhnf <$> readTVarIO v
+
+runWithCounterexample :: Monad m => m (Maybe String) -> PropertyM m Bool
+runWithCounterexample a = run a >>= \case
+    Nothing    -> pure True
+    Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)
+               >> pure False
+
 -- | Invariants
 --
 -- Testing with @'Invariant' (const Nothing)'@ is the same as testing with
@@ -131,10 +141,10 @@ prop_newTVarWithInvariant ::
   => Invariant Int
   -> Int
   -> Fun Int Int
-  -> PropertyM m Bool
+  -> m (Maybe String)
 prop_newTVarWithInvariant inv x f = do
-    v <- run $ atomically $ newTVarWithInvariant inv (applyFun f x)
-    isInWHNF v
+    v <- atomically $ newTVarWithInvariant inv (applyFun f x)
+    isInWHNF' v
 
 -- | Test 'newTVarWithInvariantIO', not to be confused with
 -- 'Checked.newTVarWithInvariantIO'.
@@ -153,11 +163,11 @@ prop_writeTVar ::
   => Invariant Int
   -> Int
   -> Fun Int Int
-  -> PropertyM m Bool
+  -> m (Maybe String)
 prop_writeTVar inv x f = do
-    v <- run $ newTVarWithInvariantIO inv x
-    run $ atomically $ writeTVar v (applyFun f x)
-    isInWHNF v
+    !v <- newTVarWithInvariantIO inv x
+    () <- atomically $ writeTVar v (applyFun f x)
+    isInWHNF' v
 
 prop_modifyTVar ::
      MonadSTM m